File-KDBX-0.906000755023420023420 014277043763 12203 5ustar00chazchaz000000000000README100644023420023420 14777314277043763 13227 0ustar00chazchaz000000000000File-KDBX-0.906NAME File::KDBX - Encrypted database to store secret text and files VERSION version 0.906 SYNOPSIS use File::KDBX; # Create a new database from scratch my $kdbx = File::KDBX->new; # Add some objects to the database my $group = $kdbx->add_group( name => 'Passwords', ); my $entry = $group->add_entry( title => 'My Bank', username => 'mreynolds', password => 's3cr3t', ); # Save the database to the filesystem $kdbx->dump_file('passwords.kdbx', 'masterpw changeme'); # Load the database from the filesystem into a new database instance my $kdbx2 = File::KDBX->load_file('passwords.kdbx', 'masterpw changeme'); # Iterate over database entries, print entry titles $kdbx2->entries->each(sub($entry, @) { say 'Entry: ', $entry->title; }); See "RECIPES" for more examples. DESCRIPTION File::KDBX provides everything you need to work with KDBX databases. 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, modify entries and more. The distribution also includes various parsers and generators for serializing and persisting databases. The 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 * ☑ 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 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 stored unencrypted in the file header. 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 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. 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 group 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 that should be kept for each entry. Default is 10. history_max_size The maximum total size (in bytes) that each individual entry's history is allowed to grow. Default is 6 MiB. maintenance_history_days The maximum age (in days) historical entries should be kept. Default it 365. 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 ubiquitous 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, as it was before loading. 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 - 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 an 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 - 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 strings and binaries in a database. The encrypted data is stored in a File::KDBX::Safe associated with the database and the actual values will be replaced with undef to indicate their protected state. Returns itself to allow method chaining. You can call lock 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 and binaries in a database, replacing undef value placeholders with their actual, 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". Example: { my $guard = $kdbx->unlock_scoped; ...; } # $kdbx is now memory-locked 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 contents are in a locked (i.e. memory-protected) state. If this is true, then some or all of the protected strings and binaries 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: value of "maintenance_history_days", 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 for you 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). You can also pass a primitive castable to a Key. 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 Key or 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 loader and dumper 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 loader and dumper 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 loader and dumper 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($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-force 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 use 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 hashref 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 algorithm 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 LIST" in perlfunc and non-fatal errors (a.k.a. warnings) are propagated using "warn LIST" in perlfunc 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 BLOCK" in perlfunc (or something like Try::Tiny) and non-fatal errors using $SIG{__WARN__} (see "%SIG" in perlvar). 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) 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. Changes100644023420023420 350614277043763 13563 0ustar00chazchaz000000000000File-KDBX-0.906Revision history for File-KDBX. 0.906 2022-08-16 19:44:09-0600 * Fixed bug where dumping a fresh database could write wrong-sized encryption IV, making the resulting serialization unreadable by some KeePass implementations. Thanks HIGHTOWE. * Fixed bugs preventing the use of memory protection with fresh databases. Thanks HIGHTOWE. * Fixed the transform_rounds method to work with Argon KDF; this now maps to the Argon iterations value if the current KDF is Argon. Thanks HIGHTOWE. 0.905 2022-08-06 12:12:42-0600 * Declared Time::Local 1.19 as a required dependency. * Declared CryptX 0.055 as a required dependency. Thanks HIGHTOWE. * Fixed minor documentation errors. 0.904 2022-07-07 21:51:17-0600 * Use expanded title, username in OTP parameters. 0.903 2022-05-11 17:17:13-0600 * Fixed parsing KDBX4 datetimes on 32-bit perls. * Fixed broken tests on perls < 5.14. 0.902 2022-05-03 19:18:06-0600 * Added support for 32-bit perls. * API change: Rename iterator accessors on group to all_*. * Declared perl 5.10.0 prerequisite. I have no intention of supporting 5.8 or earlier. * Fixed more other broken tests. Thanks CPAN testers. 0.901 2022-05-02 01:18:13-0600 * Fixed a bug where peeking at memory-protected strings and binaries does not work without unlocking the database at least once. * Added an option for writing files non-atomically. * Fixed broken tests on Windows. 0.900 2022-05-01 12:55:59-0600 * Removed the min_version methods from dumper and loader because it was unused and unnecessary. * Now use the database maintenance_history_days value as the default "max_age" value in prune_history method. * Fixed distribution prereq issues. * Cleaned up a lot of pod typos and other inaccuracies. 0.800 2022-04-30 21:14:30-0600 * Initial release t000755023420023420 014277043763 12367 5ustar00chazchaz000000000000File-KDBX-0.906kdb.t100644023420023420 1702614277043763 13502 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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 1.001004_001; 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; kdf.t100644023420023420 250014277043763 13455 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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; otp.t100644023420023420 1444314277043763 13544 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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; LICENSE100644023420023420 4366414277043763 13326 0ustar00chazchaz000000000000File-KDBX-0.906This 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 keys.t100644023420023420 1143514277043763 13713 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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 1.001004_001; 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); close($fh); 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 }; 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); 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; safe.t100644023420023420 203514277043763 13632 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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; util.t100644023420023420 1645414277043763 13723 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/usr/bin/env perl use warnings; use strict; use lib 't/lib'; use TestCommon; use File::KDBX::Util qw(:all); use Math::BigInt 1.993; use Scalar::Util qw(blessed); use Test::More; can_ok('File::KDBX::Util', qw{ 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'; }; subtest '64-bit packing' => sub { for my $test ( # bytes, value ["\xfe\xff\xff\xff\xff\xff\xff\xff", -2], ["\xff\xff\xff\xff\xff\xff\xff\xff", -1], ["\x00\x00\x00\x00\x00\x00\x00\x00", 0], ["\x01\x00\x00\x00\x00\x00\x00\x00", 1], ["\x02\x00\x00\x00\x00\x00\x00\x00", 2], ["\x01\x01\x00\x00\x00\x00\x00\x00", 257], ["\xfe\xff\xff\xff\xff\xff\xff\xff", Math::BigInt->new('-2')], ["\xff\xff\xff\xff\xff\xff\xff\xff", Math::BigInt->new('-1')], ["\x00\x00\x00\x00\x00\x00\x00\x00", Math::BigInt->new('0')], ["\x01\x00\x00\x00\x00\x00\x00\x00", Math::BigInt->new('1')], ["\x02\x00\x00\x00\x00\x00\x00\x00", Math::BigInt->new('2')], ["\x01\x01\x00\x00\x00\x00\x00\x00", Math::BigInt->new('257')], ["\xfe\xff\xff\xff\xff\xff\xff\xff", Math::BigInt->new('18446744073709551614')], ["\xff\xff\xff\xff\xff\xff\xff\xff", Math::BigInt->new('18446744073709551615')], ["\xff\xff\xff\xff\xff\xff\xff\xff", Math::BigInt->new('18446744073709551616')], # overflow ["\x02\x00\x00\x00\x00\x00\x00\x80", Math::BigInt->new('-9223372036854775806')], ["\x01\x00\x00\x00\x00\x00\x00\x80", Math::BigInt->new('-9223372036854775807')], ["\x00\x00\x00\x00\x00\x00\x00\x80", Math::BigInt->new('-9223372036854775808')], ["\x00\x00\x00\x00\x00\x00\x00\x80", Math::BigInt->new('-9223372036854775809')], # overflow ) { my ($bytes, $num) = @$test; my $desc = sprintf('Pack %s => %s', $num, unpack('H*', $bytes)); $desc =~ s/^(Pack)/$1 bigint/ if blessed $num; my $p = pack_Ql($num); is $p, $bytes, $desc or diag unpack('H*', $p); } for my $test ( # bytes, unsigned value, signed value ["\x00\x00\x00\x00\x00\x00\x00\x00", 0, 0], ["\x01\x00\x00\x00\x00\x00\x00\x00", 1, 1], ["\x02\x00\x00\x00\x00\x00\x00\x00", 2, 2], ["\xfe\xff\xff\xff\xff\xff\xff\xff", Math::BigInt->new('18446744073709551614'), -2], ["\xff\xff\xff\xff\xff\xff\xff\xff", Math::BigInt->new('18446744073709551615'), -1], ["\x02\x00\x00\x00\x00\x00\x00\x80", Math::BigInt->new('9223372036854775810'), Math::BigInt->new('-9223372036854775806')], ["\x01\x00\x00\x00\x00\x00\x00\x80", Math::BigInt->new('9223372036854775809'), Math::BigInt->new('-9223372036854775807')], ["\x00\x00\x00\x00\x00\x00\x00\x80", Math::BigInt->new('9223372036854775808'), Math::BigInt->new('-9223372036854775808')], ) { my ($bytes, $num1, $num2) = @$test; my $desc = sprintf('Unpack %s => %s', unpack('H*', $bytes), $num1); my $p = unpack_Ql($bytes); cmp_ok $p, '==', $num1, $desc or diag $p; $desc = sprintf('Unpack signed %s => %s', unpack('H*', $bytes), $num2); my $q = unpack_ql($bytes); cmp_ok $q, '==', $num2, $desc or diag $q; }; }; done_testing; META.yml100644023420023420 1305414277043763 13560 0ustar00chazchaz000000000000File-KDBX-0.906--- 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' Math::BigInt: '1.993' Test::Deep: '0' Test::Fatal: '0' Test::More: 1.001004_001 Test::Warnings: '0' lib: '0' utf8: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'Dist::Zilla version 6.025, 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.906' File::KDBX::Cipher: file: lib/File/KDBX/Cipher.pm version: '0.906' File::KDBX::Cipher::CBC: file: lib/File/KDBX/Cipher/CBC.pm version: '0.906' File::KDBX::Cipher::Stream: file: lib/File/KDBX/Cipher/Stream.pm version: '0.906' File::KDBX::Constants: file: lib/File/KDBX/Constants.pm version: '0.906' File::KDBX::Dumper: file: lib/File/KDBX/Dumper.pm version: '0.906' File::KDBX::Dumper::KDB: file: lib/File/KDBX/Dumper/KDB.pm version: '0.906' File::KDBX::Dumper::Raw: file: lib/File/KDBX/Dumper/Raw.pm version: '0.906' File::KDBX::Dumper::V3: file: lib/File/KDBX/Dumper/V3.pm version: '0.906' File::KDBX::Dumper::V4: file: lib/File/KDBX/Dumper/V4.pm version: '0.906' File::KDBX::Dumper::XML: file: lib/File/KDBX/Dumper/XML.pm version: '0.906' File::KDBX::Entry: file: lib/File/KDBX/Entry.pm version: '0.906' File::KDBX::Error: file: lib/File/KDBX/Error.pm version: '0.906' File::KDBX::Group: file: lib/File/KDBX/Group.pm version: '0.906' File::KDBX::IO: file: lib/File/KDBX/IO.pm version: '0.906' File::KDBX::IO::Crypt: file: lib/File/KDBX/IO/Crypt.pm version: '0.906' File::KDBX::IO::HashBlock: file: lib/File/KDBX/IO/HashBlock.pm version: '0.906' File::KDBX::IO::HmacBlock: file: lib/File/KDBX/IO/HmacBlock.pm version: '0.906' File::KDBX::Iterator: file: lib/File/KDBX/Iterator.pm version: '0.906' File::KDBX::KDF: file: lib/File/KDBX/KDF.pm version: '0.906' File::KDBX::KDF::AES: file: lib/File/KDBX/KDF/AES.pm version: '0.906' File::KDBX::KDF::Argon2: file: lib/File/KDBX/KDF/Argon2.pm version: '0.906' File::KDBX::Key: file: lib/File/KDBX/Key.pm version: '0.906' File::KDBX::Key::ChallengeResponse: file: lib/File/KDBX/Key/ChallengeResponse.pm version: '0.906' File::KDBX::Key::Composite: file: lib/File/KDBX/Key/Composite.pm version: '0.906' File::KDBX::Key::File: file: lib/File/KDBX/Key/File.pm version: '0.906' File::KDBX::Key::Password: file: lib/File/KDBX/Key/Password.pm version: '0.906' File::KDBX::Key::YubiKey: file: lib/File/KDBX/Key/YubiKey.pm version: '0.906' File::KDBX::Loader: file: lib/File/KDBX/Loader.pm version: '0.906' File::KDBX::Loader::KDB: file: lib/File/KDBX/Loader/KDB.pm version: '0.906' File::KDBX::Loader::Raw: file: lib/File/KDBX/Loader/Raw.pm version: '0.906' File::KDBX::Loader::V3: file: lib/File/KDBX/Loader/V3.pm version: '0.906' File::KDBX::Loader::V4: file: lib/File/KDBX/Loader/V4.pm version: '0.906' File::KDBX::Loader::XML: file: lib/File/KDBX/Loader/XML.pm version: '0.906' File::KDBX::Object: file: lib/File/KDBX/Object.pm version: '0.906' File::KDBX::Safe: file: lib/File/KDBX/Safe.pm version: '0.906' File::KDBX::Transaction: file: lib/File/KDBX/Transaction.pm version: '0.906' File::KDBX::Util: file: lib/File/KDBX/Util.pm version: '0.906' 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::Cipher::AES: '0' Crypt::Digest: '0' Crypt::Mac::HMAC: '0' Crypt::Misc: '0.049' Crypt::Mode::CBC: '0' Crypt::PRNG: '0' Crypt::Stream::ChaCha: '0.048' Crypt::Stream::Salsa20: '0.055' Data::Dumper: '0' Devel::GlobalDestruction: '0' Encode: '0' Exporter: '0' File::Temp: '0' Hash::Util::FieldHash: '0' IO::Handle: '0' IPC::Cmd: '0.84' Iterator::Simple: '0' List::Util: '1.33' Math::BigInt: '1.993' 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::Local: '1.19' Time::Piece: '1.33' XML::LibXML: '0' XML::LibXML::Reader: '0' boolean: '0' namespace::clean: '0' overload: '0' perl: '5.010' 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.906' x_authority: cpan:CCM x_generated_by_perl: v5.36.0 x_serialization_backend: 'YAML::Tiny version 1.73' x_spdx_expression: 'Artistic-1.0-Perl OR GPL-1.0-or-later' MANIFEST100644023420023420 462514277043763 13424 0ustar00chazchaz000000000000File-KDBX-0.906# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.025. 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 crypt.t100644023420023420 500214277043763 14052 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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!"; # should produce: FATAL: cipher text length has to be multiple of 16 (15) 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); } entry.t100644023420023420 1713414277043763 14103 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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->epoch, '==', 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'; $entry->username('foo'); cmp_deeply $entry->strings->{UserName}, { value => 'foo', }, 'Username setter works'; $entry->password('bar'); cmp_deeply $entry->strings->{Password}, { value => 'bar', protect => bool(1), }, 'Password setter works'; }; 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'; }; subtest 'Memory protection' => sub { my $kdbx = File::KDBX->new; is exception { $kdbx->lock }, undef, 'Can lock empty database'; $kdbx->unlock; # should be no-op since nothing was locked my $entry = $kdbx->root->add_entry( title => 'My Bank', username => 'mreynolds', password => 's3cr3t', ); $entry->string(Custom => 'foo', protect => 1); $entry->binary(Binary => 'bar', protect => 1); $entry->binary(UnprotectedBinary => 'baz'); is exception { $kdbx->lock }, undef, 'Can lock new database'; is $entry->username, 'mreynolds', 'UserName does not get locked'; is $entry->password, undef, 'Password is lockable'; is $entry->string_value('Custom'), undef, 'Custom is lockable'; is $entry->binary_value('Binary'), undef, 'Binary is lockable'; is $entry->binary_value('UnprotectedBinary'), 'baz', 'Unprotected binary does not get locked'; $kdbx->unlock; is $entry->password, 's3cr3t', 'Password is unlockable'; is $entry->string_value('Custom'), 'foo', 'Custom is unlockable'; is $entry->binary_value('Binary'), 'bar', 'Binary is unlockable'; }; done_testing; erase.t100644023420023420 174314277043763 14020 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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; error.t100644023420023420 731714277043763 14055 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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; group.t100644023420023420 77614277043763 14042 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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; kdbx2.t100644023420023420 750314277043763 13733 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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 => num(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; kdbx3.t100644023420023420 1431714277043763 13755 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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 => num(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 "\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 => num(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 => num(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 => num(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'; my $entry = $kdbx->entries->next; is $entry->title, 'Sample Entry', 'Get entry title'; is $entry->string_peek('Password'), 'ProtectedPassword', 'Peek at password from entry'; is $entry->string_peek('TestProtected'), 'ABC', 'Peek at protected string from entry'; $kdbx->unlock; 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; kdbx4.t100644023420023420 2561514277043763 13761 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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 1.001004_001; 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 => num(2), M => num(1048576), P => num(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 => num(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->transform_seed, "V\254\6m-\206*\260\305\f\0\366\24:4\235\364A\362\346\221\13)}\250\217P\303\303\2\331\245", 'Get the correct transform seed'; cmp_ok $kdbx->transform_rounds, '==', 2, 'Get the correct transform rounds'; 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 => scalar 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; is $kdbx->kdf->uuid, KDF_UUID_AES, 'Default KDF is AES'; $kdbx->kdf_parameters(fast_kdf); { 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'; }; subtest 'KDF parameters' => sub { my $kdbx = File::KDBX->new; $kdbx->version(KDBX_VERSION_4_0); is $kdbx->kdf_parameters->{+KDF_PARAM_UUID}, KDF_UUID_AES, 'Default KDF type is correct'; cmp_ok $kdbx->transform_rounds, '==', 100_000, 'Default transform rounds is correct'; $kdbx->transform_rounds(17); cmp_deeply $kdbx->kdf_parameters, { "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352", R => num(17), S => ignore(), }, 'Set transform rounds for AES KDF'; $kdbx->kdf_parameters({KDF_PARAM_UUID() => KDF_UUID_ARGON2D}); cmp_ok $kdbx->transform_rounds, '==', 10, 'Default Argon2D transform rounds is correct'; $kdbx->transform_rounds(17); cmp_deeply $kdbx->kdf_parameters, { "\$UUID" => "\357cm\337\214)DK\221\367\251\244\3\343\n\f", I => num(17), }, 'Set transform rounds for Argon KDF'; }; done_testing; query.t100644023420023420 1702714277043763 14110 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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; META.json100644023420023420 2435214277043763 13733 0ustar00chazchaz000000000000File-KDBX-0.906{ "abstract" : "Encrypted database to store secret text and files", "author" : [ "Charles McGarvey " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.025, 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::Cipher::AES" : "0", "Crypt::Digest" : "0", "Crypt::Mac::HMAC" : "0", "Crypt::Misc" : "0.049", "Crypt::Mode::CBC" : "0", "Crypt::PRNG" : "0", "Crypt::Stream::ChaCha" : "0.048", "Crypt::Stream::Salsa20" : "0.055", "Data::Dumper" : "0", "Devel::GlobalDestruction" : "0", "Encode" : "0", "Exporter" : "0", "File::Temp" : "0", "Hash::Util::FieldHash" : "0", "IO::Handle" : "0", "IPC::Cmd" : "0.84", "Iterator::Simple" : "0", "List::Util" : "1.33", "Math::BigInt" : "1.993", "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::Local" : "1.19", "Time::Piece" : "1.33", "XML::LibXML" : "0", "XML::LibXML::Reader" : "0", "boolean" : "0", "namespace::clean" : "0", "overload" : "0", "perl" : "5.010", "strict" : "0", "warnings" : "0" }, "suggests" : { "Crypt::Stream::Serpent" : "0.055", "Crypt::Stream::Twofish" : "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", "Math::BigInt" : "1.993", "Test::Deep" : "0", "Test::Fatal" : "0", "Test::More" : "1.001004_001", "Test::Warnings" : "0", "lib" : "0", "utf8" : "0" }, "suggests" : { "POSIX::1003" : "0" } } }, "provides" : { "File::KDBX" : { "file" : "lib/File/KDBX.pm", "version" : "0.906" }, "File::KDBX::Cipher" : { "file" : "lib/File/KDBX/Cipher.pm", "version" : "0.906" }, "File::KDBX::Cipher::CBC" : { "file" : "lib/File/KDBX/Cipher/CBC.pm", "version" : "0.906" }, "File::KDBX::Cipher::Stream" : { "file" : "lib/File/KDBX/Cipher/Stream.pm", "version" : "0.906" }, "File::KDBX::Constants" : { "file" : "lib/File/KDBX/Constants.pm", "version" : "0.906" }, "File::KDBX::Dumper" : { "file" : "lib/File/KDBX/Dumper.pm", "version" : "0.906" }, "File::KDBX::Dumper::KDB" : { "file" : "lib/File/KDBX/Dumper/KDB.pm", "version" : "0.906" }, "File::KDBX::Dumper::Raw" : { "file" : "lib/File/KDBX/Dumper/Raw.pm", "version" : "0.906" }, "File::KDBX::Dumper::V3" : { "file" : "lib/File/KDBX/Dumper/V3.pm", "version" : "0.906" }, "File::KDBX::Dumper::V4" : { "file" : "lib/File/KDBX/Dumper/V4.pm", "version" : "0.906" }, "File::KDBX::Dumper::XML" : { "file" : "lib/File/KDBX/Dumper/XML.pm", "version" : "0.906" }, "File::KDBX::Entry" : { "file" : "lib/File/KDBX/Entry.pm", "version" : "0.906" }, "File::KDBX::Error" : { "file" : "lib/File/KDBX/Error.pm", "version" : "0.906" }, "File::KDBX::Group" : { "file" : "lib/File/KDBX/Group.pm", "version" : "0.906" }, "File::KDBX::IO" : { "file" : "lib/File/KDBX/IO.pm", "version" : "0.906" }, "File::KDBX::IO::Crypt" : { "file" : "lib/File/KDBX/IO/Crypt.pm", "version" : "0.906" }, "File::KDBX::IO::HashBlock" : { "file" : "lib/File/KDBX/IO/HashBlock.pm", "version" : "0.906" }, "File::KDBX::IO::HmacBlock" : { "file" : "lib/File/KDBX/IO/HmacBlock.pm", "version" : "0.906" }, "File::KDBX::Iterator" : { "file" : "lib/File/KDBX/Iterator.pm", "version" : "0.906" }, "File::KDBX::KDF" : { "file" : "lib/File/KDBX/KDF.pm", "version" : "0.906" }, "File::KDBX::KDF::AES" : { "file" : "lib/File/KDBX/KDF/AES.pm", "version" : "0.906" }, "File::KDBX::KDF::Argon2" : { "file" : "lib/File/KDBX/KDF/Argon2.pm", "version" : "0.906" }, "File::KDBX::Key" : { "file" : "lib/File/KDBX/Key.pm", "version" : "0.906" }, "File::KDBX::Key::ChallengeResponse" : { "file" : "lib/File/KDBX/Key/ChallengeResponse.pm", "version" : "0.906" }, "File::KDBX::Key::Composite" : { "file" : "lib/File/KDBX/Key/Composite.pm", "version" : "0.906" }, "File::KDBX::Key::File" : { "file" : "lib/File/KDBX/Key/File.pm", "version" : "0.906" }, "File::KDBX::Key::Password" : { "file" : "lib/File/KDBX/Key/Password.pm", "version" : "0.906" }, "File::KDBX::Key::YubiKey" : { "file" : "lib/File/KDBX/Key/YubiKey.pm", "version" : "0.906" }, "File::KDBX::Loader" : { "file" : "lib/File/KDBX/Loader.pm", "version" : "0.906" }, "File::KDBX::Loader::KDB" : { "file" : "lib/File/KDBX/Loader/KDB.pm", "version" : "0.906" }, "File::KDBX::Loader::Raw" : { "file" : "lib/File/KDBX/Loader/Raw.pm", "version" : "0.906" }, "File::KDBX::Loader::V3" : { "file" : "lib/File/KDBX/Loader/V3.pm", "version" : "0.906" }, "File::KDBX::Loader::V4" : { "file" : "lib/File/KDBX/Loader/V4.pm", "version" : "0.906" }, "File::KDBX::Loader::XML" : { "file" : "lib/File/KDBX/Loader/XML.pm", "version" : "0.906" }, "File::KDBX::Object" : { "file" : "lib/File/KDBX/Object.pm", "version" : "0.906" }, "File::KDBX::Safe" : { "file" : "lib/File/KDBX/Safe.pm", "version" : "0.906" }, "File::KDBX::Transaction" : { "file" : "lib/File/KDBX/Transaction.pm", "version" : "0.906" }, "File::KDBX::Util" : { "file" : "lib/File/KDBX/Util.pm", "version" : "0.906" } }, "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.906", "x_authority" : "cpan:CCM", "x_generated_by_perl" : "v5.36.0", "x_serialization_backend" : "Cpanel::JSON::XS version 4.30", "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later" } object.t100644023420023420 1461414277043763 14210 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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; yubikey.t100644023420023420 554014277043763 14401 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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; Makefile.PL100644023420023420 672214277043763 14245 0ustar00chazchaz000000000000File-KDBX-0.906# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.025. use strict; use warnings; use 5.010; 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.010", "NAME" => "File::KDBX", "PREREQ_PM" => { "Carp" => 0, "Crypt::Argon2" => 0, "Crypt::Cipher" => 0, "Crypt::Cipher::AES" => 0, "Crypt::Digest" => 0, "Crypt::Mac::HMAC" => 0, "Crypt::Misc" => "0.049", "Crypt::Mode::CBC" => 0, "Crypt::PRNG" => 0, "Crypt::Stream::ChaCha" => "0.048", "Crypt::Stream::Salsa20" => "0.055", "Data::Dumper" => 0, "Devel::GlobalDestruction" => 0, "Encode" => 0, "Exporter" => 0, "File::Temp" => 0, "Hash::Util::FieldHash" => 0, "IO::Handle" => 0, "IPC::Cmd" => "0.84", "Iterator::Simple" => 0, "List::Util" => "1.33", "Math::BigInt" => "1.993", "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::Local" => "1.19", "Time::Piece" => "1.33", "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, "Math::BigInt" => "1.993", "Test::Deep" => 0, "Test::Fatal" => 0, "Test::More" => "1.001004_001", "Test::Warnings" => 0, "lib" => 0, "utf8" => 0 }, "VERSION" => "0.906", "test" => { "TESTS" => "t/*.t" } ); my %FallbackPrereqs = ( "Carp" => 0, "Crypt::Argon2" => 0, "Crypt::Cipher" => 0, "Crypt::Cipher::AES" => 0, "Crypt::Digest" => 0, "Crypt::Mac::HMAC" => 0, "Crypt::Misc" => "0.049", "Crypt::Mode::CBC" => 0, "Crypt::PRNG" => 0, "Crypt::Stream::ChaCha" => "0.048", "Crypt::Stream::Salsa20" => "0.055", "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.84", "IPC::Open3" => 0, "Iterator::Simple" => 0, "List::Util" => "1.33", "Math::BigInt" => "1.993", "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" => "1.001004_001", "Test::Warnings" => 0, "Text::ParseWords" => 0, "Time::Local" => "1.19", "Time::Piece" => "1.33", "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); database.t100644023420023420 1775614277043763 14520 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/usr/bin/env perl use utf8; use warnings; use strict; use FindBin qw($Bin); use lib "$Bin/lib"; use TestCommon; use File::KDBX::Constants qw(:cipher :version); use File::KDBX; use File::Temp qw(tempfile); use Test::Deep; use Test::More 1.001004_001; 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'; cmp_ok $kdbx->version, '==', KDBX_VERSION_3_1, 'Default KDBX file version is 3.1'; is $kdbx->cipher_id, CIPHER_UUID_AES256, 'Cipher of new database is AES256'; cmp_ok length($kdbx->encryption_iv), '==', 16, 'Encryption IV of new databse is 16 bytes'; my $kdbx2 = File::KDBX->new(version => KDBX_VERSION_4_0); is $kdbx2->cipher_id, CIPHER_UUID_CHACHA20, 'Cipher of new v4 database is ChaCha20'; cmp_ok length($kdbx2->encryption_iv), '==', 12, 'Encryption IV of new databse is 12 bytes'; }; 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 (@_) { 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->all_entries->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'; }; subtest 'Dumping to filesystem' => sub { my $kdbx = File::KDBX->new; $kdbx->add_entry(title => 'Foo', password => 'whatever'); my ($fh, $filepath) = tempfile('kdbx-XXXXXX', TMPDIR => 1, UNLINK => 1); close($fh); $kdbx->dump($filepath, 'a'); my $kdbx2 = File::KDBX->load($filepath, 'a'); my $entry = $kdbx2->entries->map(sub { $_->title.'/'.$_->expand_password })->next; is $entry, 'Foo/whatever', 'Dump and load an entry'; $kdbx->dump($filepath, key => 'a', atomic => 0); $kdbx2 = File::KDBX->load($filepath, 'a'); $entry = $kdbx2->entries->map(sub { $_->title.'/'.$_->expand_password })->next; is $entry, 'Foo/whatever', 'Dump and load an entry (non-atomic)'; }; done_testing; iterator.t100644023420023420 672714277043763 14561 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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; perlcritic.rc100644023420023420 35514277043763 14735 0ustar00chazchaz000000000000File-KDBX-0.906# 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] hash-block.t100644023420023420 352014277043763 14727 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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; hmac-block.t100644023420023420 376714277043763 14731 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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; kdf-aes-pp.t100644023420023420 122714277043763 14645 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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; references.t100644023420023420 237514277043763 15044 0ustar00chazchaz000000000000File-KDBX-0.906/t#!/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; 00-compile.t100644023420023420 474014277043763 14566 0ustar00chazchaz000000000000File-KDBX-0.906/tuse 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 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}; author000755023420023420 014277043763 14061 5ustar00chazchaz000000000000File-KDBX-0.906/xteol.t100644023420023420 462114277043763 15170 0ustar00chazchaz000000000000File-KDBX-0.906/xt/authoruse 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; File000755023420023420 014277043763 13551 5ustar00chazchaz000000000000File-KDBX-0.906/libKDBX.pm100644023420023420 25652414277043763 15055 0ustar00chazchaz000000000000File-KDBX-0.906/lib/Filepackage File::KDBX; # ABSTRACT: Encrypted database to store secret text and files use 5.010; 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 1.33; use boolean; use namespace::clean; our $VERSION = '0.906'; # 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 $data; $data = shift if is_plain_hashref($_[0]); my $self = bless $data // {}, $class; $self->init(@_); $self->_set_nonlazy_attributes if !$data; 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' => sub { $_[0]->version < KDBX_VERSION_4_0 ? CIPHER_UUID_AES256 : 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($_[0]->version < KDBX_VERSION_4_0 ? 16 : 12) }, 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' => HISTORY_DEFAULT_MAX_AGE, 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} // $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->all_groups(%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} // $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->all_entries(%args); } ############################################################################## sub objects { my $self = shift; my %args = @_ % 2 == 0 ? @_ : (base => shift, @_); my $base = delete $args{base} // $self->root; return $base->all_objects(%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; # Find things to lock: my @strings; $self->entries(history => 1)->each(sub { my $strings = $_->strings; for my $string_key (keys %$strings) { my $string = $strings->{$string_key}; push @strings, $string if $string->{protect} // $self->memory_protection($string_key); } push @strings, grep { $_->{protect} } values %{$_->binaries}; }); return $self if !@strings; # nothing to do if (my $safe = $self->_safe) { $safe->add(\@strings); } else { $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 } ############################################################################## # 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} // $self->maintenance_history_days // 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; my $iv_size = 16; $iv_size = $self->cipher(key => "\0" x 32)->iv_size if KDBX_VERSION_4_0 <= $self->version; $self->encryption_iv(random_bytes($iv_size)); $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}; $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; my $param = KDF_PARAM_AES_SEED; # Short cut: Argon2 uses the same parameter name ("S") $self->headers->{+HEADER_TRANSFORM_SEED} = $self->headers->{+HEADER_KDF_PARAMETERS}{$param} = shift if @_; $self->headers->{+HEADER_TRANSFORM_SEED} = $self->headers->{+HEADER_KDF_PARAMETERS}{$param} //= random_bytes(32); } sub transform_rounds { my $self = shift; require File::KDBX::KDF; my $info = $File::KDBX::KDF::ROUNDS_INFO{$self->kdf_parameters->{+KDF_PARAM_UUID} // ''} // $File::KDBX::KDF::DEFAULT_ROUNDS_INFO; $self->headers->{+HEADER_TRANSFORM_ROUNDS} = $self->headers->{+HEADER_KDF_PARAMETERS}{$info->{p}} = shift if @_; $self->headers->{+HEADER_TRANSFORM_ROUNDS} = $self->headers->{+HEADER_KDF_PARAMETERS}{$info->{p}} //= $info->{d}; } sub cipher { my $self = shift; my %args = @_; $args{uuid} //= $self->cipher_id; $args{iv} //= $self->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.906 =head1 SYNOPSIS use File::KDBX; # Create a new database from scratch my $kdbx = File::KDBX->new; # Add some objects to the database my $group = $kdbx->add_group( name => 'Passwords', ); my $entry = $group->add_entry( title => 'My Bank', username => 'mreynolds', password => 's3cr3t', ); # Save the database to the filesystem $kdbx->dump_file('passwords.kdbx', 'masterpw changeme'); # Load the database from the filesystem into a new database instance my $kdbx2 = File::KDBX->load_file('passwords.kdbx', 'masterpw changeme'); # Iterate over database entries, print entry titles $kdbx2->entries->each(sub($entry, @) { say 'Entry: ', $entry->title; }); See L for more examples. =head1 DESCRIPTION B provides everything you need to work with KDBX databases. 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, modify entries and more. The distribution also includes various parsers and generators for serializing and persisting databases. The 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 =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 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 stored unencrypted in the file header. 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 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 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. B 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 group 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 that should be kept for each entry. Default is 10. =head2 history_max_size The maximum total size (in bytes) that each individual entry's history is allowed to grow. Default is 6 MiB. =head2 maintenance_history_days The maximum age (in days) historical entries should be kept. Default it 365. =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 ubiquitous 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, as it was before loading. 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> - 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 an 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> - 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 strings and binaries in a database. The encrypted data is stored in a L<File::KDBX::Safe> associated with the database and the actual values will be replaced with C<undef> to indicate their protected state. Returns itself to allow method chaining. You can call C<lock> 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 and binaries in a database, replacing C<undef> value placeholders with their actual, 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>. Example: { my $guard = $kdbx->unlock_scoped; ...; } # $kdbx is now memory-locked =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 contents are in a locked (i.e. memory-protected) state. If this is true, then some or all of the protected strings and binaries 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: value of L</maintenance_history_days>, 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 for you 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). You can also pass a primitive castable to a B<Key>. 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 B<Key> or 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 loader and dumper 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 loader and dumper 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 loader and dumper 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($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-force 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 use 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 hashref 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<algorithm> 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 =over 4 =item * IDS order of groups is: Root, Group1, Group2, Group3 =item * IDS order of entries is: EntryA, EntryB, EntryC =item * IDS order of objects is: Root, Group1, EntryA, Group2, EntryB, Group3, EntryC =item * DFS order of groups is: Group2, Group1, Group3, Root =item * DFS order of entries is: EntryB, EntryA, EntryC =item * DFS order of objects is: Group2, EntryB, Group1, EntryA, Group3, EntryC, Root =item * BFS order of groups is: Root, Group1, Group3, Group2 =item * BFS order of entries is: EntryA, EntryC, EntryB =item * BFS order of objects is: Root, Group1, EntryA, Group3, EntryC, Group2, EntryB =back =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<perlfunc/"die LIST"> and non-fatal errors (a.k.a. warnings) are propagated using L<perlfunc/"warn LIST"> 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<perlfunc/"eval BLOCK"> (or something like L<Try::Tiny>) and non-fatal errors using C<$SIG{__WARN__}> (see L<perlvar/%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 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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������placeholders.t��������������������������������������������������������������������������������������100644��023420��023420�� 5003�14277043763� 15357� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t������������������������������������������������������������������������������������������������������������������������������������������������������#!/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; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������files�����������������������������������������������������������������������������������������������000755��023420��023420�� 0�14277043763� 13471� 5����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t������������������������������������������������������������������������������������������������������������������������������������������������������basic.kdb�������������������������������������������������������������������������������������������100644��023420��023420�� 4654�14277043763� 15405� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������٢eK�����z+ ms2'!7q 맒!Ljw������`UnMF GY )%X-8̗ ^:!fީ[`RGUeT3:��6AmN Q2}Il_Ozcdax&!ĆBmH60Q_bUmL=D .BDjܨJ'g_8^+b$5P)gQ@ `#f8cj7 UnǰZINF狼nڝ.nh!u!�z=&4֝rg8pug&*čV-lM Rhlsf3,$ExwR1da0Ywf -zF%gqާ<O"p *Q OADw9$9<A؃XkJ#iVQC 7P5X̋s=L.yEwBx;A 5$+)s/q3^ > Ey R�62&Zzy p/7B2OUXR :?.;=;QTb n�GO@ % 9=DmkX"@UO}[eFYz*G%blmpc}o3kU0'7E"d:)؉f?ٵLI~΂KefwX@qe )9pxe(FOH/,ųoK<}*yN3Ag1ix"muٿ VC]jëX.�aLe*DZŃƎEE S5u[Jpy.夑!c r3T |xl| ;>͛@Λ:snEB/ ֞}4Kzs*oCd:mK1l)2e† ( c Qm،Hҥ!Q) tN-gLŧ3v%HH:lM)5ߣkn}L`ȝ侂F} ZyŜQJ޷ul,-[e|hr#k0[f}Y ;Hɍ�~Cjڨ&"BhW&HZ9RK�XdЙY3>d+L}]+i/7Vj2㔭Lbn9'2˸2Ҹ5{,We܃C`$\VU`b곟`h-[O L\N"}G{v.G_hGYYCT7{c/n=Q +0*|izo~I&.)9/wJt[>3غBw7եmCq8T )zdxֶj٪J%zm* fOQzB7_\owijmPan0fK�wiEY\H'pF(GwHMؙ2pZyvМ_kcw1ȕtHջ)Q!!|zл9r.<?_#nZ%Xj2P C3稚$g2w% Og?l* 82R "%n.f46hP&QѦ8@8[ZG\)A89'Nڶ8IC'vkR΅&D,^$!b] {(JCRK`AWȺ[Ng谗oTgG#YKuK2ө~Ugu6F mWyuUy'< v:9]._(|62)5d [#*{n\c^B' [s"};#oS#"8~pPճU i<ƠsPIl0[Ca6+_ٞ5=6n9޻b>V1mQK猭4͟H$z$X_f󀘏[N?BW2n6uoOPT*8ZY N 0 ,l8ݬ3uy|7P:t[T/r'wxzĿ7?f'tꏖal::$C~p[;ZF~J2AaS*uSAwfG.[(!!n%wrTy oxCW-l;pf>@ ':H\'4 KG*@ rO-O]L8j{FrLL%guVG"A'6bxer?iIqBJb̗Ej9A074Uy]Y}:@H�&h]I; s<>T{0+ʠ*Wp<c������������������������������������������������������������������������������������bin�������������������������������������������������������������������������������������������������000755��023420��023420�� 0�14277043763� 14241� 5����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������ykinfo����������������������������������������������������������������������������������������������100755��023420��023420�� 1040�14277043763� 15621� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files/bin��������������������������������������������������������������������������������������������������������������������������������������������#!/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; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������critic.t��������������������������������������������������������������������������������������������100644��023420��023420�� 201�14277043763� 15634� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/xt/author����������������������������������������������������������������������������������������������������������������������������������������������#!perl use strict; use warnings; use Test::Perl::Critic (-profile => "perlcritic.rc") x!! -e "perlcritic.rc"; all_critic_ok(); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������KDBX������������������������������������������������������������������������������������������������000755��023420��023420�� 0�14277043763� 14301� 5����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File�����������������������������������������������������������������������������������������������������������������������������������������������IO.pm�����������������������������������������������������������������������������������������������100644��023420��023420�� 24371�14277043763� 15335� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������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.906'; # 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.906 =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 �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������CP-1252.kdb�����������������������������������������������������������������������������������������100644��023420��023420�� 1154�14277043763� 15205� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������٢eK�����.LkU*|2I\e۸׾(������i(f4Qڳz5cHḙ̂>*薡!Ë8Lr uf5!Pr ���SM+>u-62 2l6^R[ -39IVko$9^+f=32PE9Ƃ(_YZ"qP!2v].42J-c<Syo%}b`:f8=# ~ER,hl"z~=%`E oJ-vR;$ 5�~vV a!6OMݩpBg7Jr餀#-ޗC*+cp X, 扺O42pH~$%pKck}xy5*p(|.Kkiۣٳo'=5DdW^S{CƄ1i;.\$HQ&SMP !!/Nr~Q녳4 ڦu&oKp!X;jPH #Ŏ$^�3PxrOxg[��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Twofish.kdb�����������������������������������������������������������������������������������������100644��023420��023420�� 1154�14277043763� 15737� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������٢eK �����ss4`P_![}:k������mޔ S| ?8 J D,AS@o\KJ~R['��s'E<m9tu${ie'}jݵ!˜&}Y;ÿyV^ ι� ҊtSYܿ* NI՞x:DʀJ~Zv-ZCxO+V݂,QCk:F--dD"E+gJH^Ƹ :y 0 zusں"fjϡ}ɿAeg BZ^Byq{HcKPuВ]*b >j(xU c]2{ϥ9)F\xzC-{PJ?LiE Wl[' ܁My:˦;')Q*"Is-"7'e-s(R,*F>V48V)铠Ҕ;!ryM_B R$[+}=>sL(-OCu_՝/`h��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������lib�������������������������������������������������������������������������������������������������000755��023420��023420�� 0�14277043763� 13135� 5����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t������������������������������������������������������������������������������������������������������������������������������������������������������TestCommon.pm���������������������������������������������������������������������������������������100644��023420��023420�� 5534�14277043763� 15732� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/lib��������������������������������������������������������������������������������������������������������������������������������������������������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'; } # Returns parameters for a fast KDF so that running tests isn't pointlessly slow. 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; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������no-tabs.t�������������������������������������������������������������������������������������������100644��023420��023420�� 4567�14277043763� 15765� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/xt/author����������������������������������������������������������������������������������������������������������������������������������������������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; �����������������������������������������������������������������������������������������������������������������������������������������KDF.pm����������������������������������������������������������������������������������������������100644��023420��023420�� 15026�14277043763� 15427� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������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.906'; # VERSION my %KDFS; our %ROUNDS_INFO = ( KDF_UUID_ARGON2D() => {p => KDF_PARAM_ARGON2_ITERATIONS, d => KDF_DEFAULT_ARGON2_ITERATIONS}, KDF_UUID_ARGON2ID() => {p => KDF_PARAM_ARGON2_ITERATIONS, d => KDF_DEFAULT_ARGON2_ITERATIONS}, ); our $DEFAULT_ROUNDS_INFO = { p => KDF_PARAM_AES_ROUNDS, d => KDF_DEFAULT_AES_ROUNDS, }; 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.906 =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 L</new> to set attributes. You normally shouldn't call this. Returns itself to allow method chaining. =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 and set 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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Key.pm����������������������������������������������������������������������������������������������100644��023420��023420�� 17164�14277043763� 15560� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������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.906'; # 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.906 =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 well-supported configurations: =over 4 =item * One password =item * One key file =item * Composite of 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<memory protection|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 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������keys������������������������������������������������������������������������������������������������000755��023420��023420�� 0�14277043763� 14444� 5����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������hex.key���������������������������������������������������������������������������������������������100644��023420��023420�� 100�14277043763� 16051� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files/keys�������������������������������������������������������������������������������������������������������������������������������������������425903c6e61b0cf0e90d774ad78ef41305412fe009047da0bcf03d9713641449����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������distmeta.t������������������������������������������������������������������������������������������100644��023420��023420�� 172�14277043763� 16200� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/xt/author����������������������������������������������������������������������������������������������������������������������������������������������#!perl # This file was automatically generated by Dist::Zilla::Plugin::MetaTests. use Test::CPAN::Meta; meta_yaml_ok(); ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Safe.pm���������������������������������������������������������������������������������������������100644��023420��023420�� 21676�14277043763� 15711� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������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.906'; # 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, off => $self->{counter}}; $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.906 =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 ������������������������������������������������������������������Util.pm���������������������������������������������������������������������������������������������100644��023420��023420�� 102654�14277043763� 15764� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������package File::KDBX::Util; # ABSTRACT: Utility functions for working with KDBX files use 5.010; use warnings; use strict; use Crypt::PRNG qw(random_bytes random_string); use Encode qw(decode encode); use Exporter qw(import); 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 1.33; use boolean; use namespace::clean -except => 'import'; our $VERSION = '0.906'; # VERSION our %EXPORT_TAGS = ( assert => [qw(DEBUG assert)], 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)], int => [qw(int64 pack_ql pack_Ql unpack_ql unpack_Ql)], io => [qw(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 = !1; } $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 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 int64 { require Config; if ($Config::Config{ivsize} < 8) { require Math::BigInt; return Math::BigInt->new(@_); } return 0 + shift; } sub pack_Ql { my $num = shift; require Config; if ($Config::Config{ivsize} < 8) { if (blessed $num && $num->can('as_hex')) { require Math::BigInt; return "\xff\xff\xff\xff\xff\xff\xff\xff" if Math::BigInt->new('18446744073709551615') <= $num; return "\x00\x00\x00\x00\x00\x00\x00\x80" if $num <= Math::BigInt->new('-9223372036854775808'); my $neg; if ($num < 0) { $neg = 1; $num = -$num; } my $hex = $num->as_hex; $hex =~ s/^0x/000000000000000/; my $bytes = reverse pack('H16', substr($hex, -16)); $bytes .= "\0" x (8 - length $bytes) if length $bytes < 8; if ($neg) { # two's compliment $bytes = join('', map { chr(~ord($_) & 0xff) } split(//, $bytes)); substr($bytes, 0, 1, chr(ord(substr($bytes, 0, 1)) + 1)); } return $bytes; } else { my $pad = $num < 0 ? "\xff" : "\0"; return pack('L<', $num) . ($pad x 4); }; } return pack('Q<', $num); } sub pack_ql { goto &pack_Ql } sub unpack_Ql { my $bytes = shift; require Config; if ($Config::Config{ivsize} < 8) { require Math::BigInt; return Math::BigInt->new('0x' . unpack('H*', scalar reverse $bytes)); } return unpack('Q<', $bytes); } sub unpack_ql { my $bytes = shift; require Config; if ($Config::Config{ivsize} < 8) { require Math::BigInt; if (ord(substr($bytes, -1, 1)) & 128) { return Math::BigInt->new('-9223372036854775808') if $bytes eq "\x00\x00\x00\x00\x00\x00\x00\x80"; # two's compliment substr($bytes, 0, 1, chr(ord(substr($bytes, 0, 1)) - 1)); $bytes = join('', map { chr(~ord($_) & 0xff) } split(//, $bytes)); return -Math::BigInt->new('0x' . unpack('H*', scalar reverse $bytes)); } else { return Math::BigInt->new('0x' . unpack('H*', scalar reverse $bytes)); } } return unpack('q<', $bytes); } 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.906 =head1 FUNCTIONS =head2 load_xs $bool = load_xs(); $bool = load_xs($version); Attempt to load L<File::KDBX::XS>. Return truthy if it 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 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 int64 $int = int64($string); Get a scalar integer capable of holding 64-bit values, initialized with a given default value. On a 64-bit perl, it will return a regular SvIV. On a 32-bit perl it will return a L<Math::BigInt>. =head2 pack_Ql $bytes = pack_Ql($int); Like C<pack('QE<lt>', $int)>, but also works on 32-bit perls. =head2 pack_ql $bytes = pack_ql($int); Like C<pack('qE<lt>', $int)>, but also works on 32-bit perls. =head2 unpack_Ql $int = unpack_Ql($bytes); Like C<unpack('QE<lt>', $bytes)>, but also works on 32-bit perls. =head2 unpack_ql $int = unpack_ql($bytes); Like C<unpack('qE<lt>', $bytes)>, but also works on 32-bit perls. =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/"Declarative Syntax"> 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<perlfunc/"read FILEHANDLE,SCALAR,LENGTH,OFFSET"> 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 ������������������������������������������������������������������������������������NonAscii.kdbx���������������������������������������������������������������������������������������100644��023420��023420�� 5456�14277043763� 16220� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������٢gK���1qCPX!jZ����� � {6dvW[HN"A1􋖟M �lU#ƙ %UJ36�p�������msU ^] �Z] `8=> ξz W6Q, �Ph"h^mf9U˞zF 9=})T ������ SŕxgLp5Pc8)NKWj/QAqGVVTͭCkJu=&ivār A{ )0/0Q-^h-?}(cRuh̗Vj&XR !9tx_)K\#QB�YڙQ1h^)]fñ͕D Z2?6`Zz>7ԌW,fp(Bx) c kAv3(V~$-=NX<7f)irβJ.Ȝ)nBÕGdmqG- 7z?w4y'Vkk^ҴCy�/h } D1KXF~x.[*NGY{sa`SJwc1xjG;i1$^DЂhWFl'ph9GmP-Md=nj1՛zu @.Ma]9=C➟I[Z|/SS=ƔTn/<9X&] c 5I,LdA%YHt!!6\@@XˑCrÈE'*9ecj5<H1ah7ɄABs#x Sg t#*qYcz28q`=.3,kMq%IՈ:r`v^J[pL fތ^a Fڵyp Eaw`*M݅@ۍ`y| QL_J tǨ^6QZv\P8-؉|d_YL|UH[r;q vw:#5F< Yyy(LOvi v=]RF8b#d;*C9f=D] lXMJd΢9 nf4d`nwn<0 ; ڣLN dLM2:})iP{7jY?T6OFn~k|#{CԺ_ɚ-9{F{/ST<FnHo&6QX w6j^~p3t0;l!-osp374)&aIYʵ"insۓ6A\%F Gn�ˆ⫧f+.uQ'jJ 0d0;*)v[d\c>eL:gIN  4pTʎeZ4HP@<(^M.A.dX[Ƀ?%qjY Hŀi]ܒ;߉C.O™Yx$*>7 'ǻy1xKT)NVu8?tRw`NϠ&iv 07' /331ܰ$dfkab-4zi6.o zkYX^nO:kKv J: TdRܸ>N.Y Ki> L˜1ȭGt`)?xra[pV(1*B& o~ٰ.w v}⼍[10diSyu󥽇&+qbY9KU-y}-4LiU}\5q Uxz}_'aWNc;k"?{ aP/\,bש՛Ei̺t[Ӻjy縌[eؙs,7(v I\OX;G(6S:\v J䡃5{,* *?uAp~B; T4'ӻDThhgr6eh>=C$EĠd( bM| }Wކ_3Fk3 ==fK䭻FoϢ) I/-lD4*ұyv0�>R!DLиWՂx}>lo LZ]"$f/BjP:J*taCXGJ&r65vݝ$1�;O'Y!&bp$;k+V"Vok389bn]On]Ȧ5"bC`5)]EȑfW#Uӷ\4�I?= '.pK :N:!ҩ& +w`og077K DC*W!lFm@YUKLUtDM< 4e{#\d"Iw-R3dǸ<#$pdX}ǏDP#|O"d&Fe jUW`PRԓd< (be<n $4X9 "omy �^ħ4:}WvS+*!b{a{]7Z~h%`Tahp J-5F(xu) \5OOfU]d10(V+lp@Fh)w-ELKZҢo^P-M<䇙& ^#gg Xs["Th<[0s������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������memory-protection.t���������������������������������������������������������������������������������100644��023420��023420�� 22473�14277043763� 16440� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t������������������������������������������������������������������������������������������������������������������������������������������������������#!/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 1.001004_001; 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 $?; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������00-report-prereqs.t���������������������������������������������������������������������������������100644��023420��023420�� 13452�14277043763� 16150� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t������������������������������������������������������������������������������������������������������������������������������������������������������#!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: ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Entry.pm��������������������������������������������������������������������������������������������100644��023420��023420�� 122465�14277043763� 16152� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������package File::KDBX::Entry; # ABSTRACT: A KDBX database entry use warnings; use strict; use Crypt::Misc 0.049 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(any 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 1.33; use boolean; use namespace::clean; extends 'File::KDBX::Object'; our $VERSION = '0.906'; # 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}); # Auto-vivify the standard strings. if (!exists $self->{strings}{$key} && $STANDARD_STRINGS{$key}) { $args{value} //= ''; $args{protect} //= true if $self->_protect($key); } while (my ($field, $value) = each %args) { $self->{strings}{$key}{$field} = $value; } 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->expand_title || 'KDBX', account => $self->expand_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->expand_title || 'KDBX', account => $self->expand_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} // eval { $self->kdbx->maintenance_history_days } // 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.906 =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>. View its documentation to see other attributes and methods available on entries. =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 C<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-type 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 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 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 L</Placeholders>, most commonly C<{USERNAME}> and C<{PASSWORD}>. =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 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 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. =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($string_key); 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 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') >>. =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 �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Error.pm��������������������������������������������������������������������������������������������100644��023420��023420�� 14265�14277043763� 16120� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������package File::KDBX::Error; # ABSTRACT: Represents something bad that happened use 5.010; use warnings; use strict; use Exporter qw(import); use Scalar::Util qw(blessed looks_like_number); use namespace::clean -except => 'import'; our $VERSION = '0.906'; # 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.906 =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 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Group.pm��������������������������������������������������������������������������������������������100644��023420��023420�� 45100�14277043763� 16113� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������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 1.33; use boolean; use namespace::clean; extends 'File::KDBX::Object'; our $VERSION = '0.906'; # 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 all_entries { 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->all_groups(%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 all_groups { 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 all_objects { 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->all_groups(%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.906 =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. A B<File::KDBX::Group> is a subclass of L<File::KDBX::Object>. View its documentation to see other attributes and methods available on groups. =head1 ATTRIBUTES =head2 name The human-readable name of the group. =head2 notes Free form text string associated with the group. =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 entries Array of entries contained within the group. =head2 groups Array of subgroups contained within the group. =head1 METHODS =head2 entries \@entries = $group->entries; Get an array of direct child entries within a group. =head2 all_entries \&iterator = $kdbx->all_entries(%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 all_groups \&iterator = $group->all_groups(%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 all_objects \&iterator = $groups->all_objects(%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 in 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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������FileKeyHex.kdb��������������������������������������������������������������������������������������100644��023420��023420�� 1174�14277043763� 16313� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������٢eK�����Ǯٵ"XLnjᎦhyX(������u/Ԧ.4lx͈'h?2ێRM9&3`9]u2$,ONP��XQđqhj_u³Hw'[y#%cs}zXA+ ɼ "644FfRi^ԅі`;]y#̘7BߠӃ1wD䤙sѵa{n)i�88T+$h J#~ض ]osCb1&'A]BoYD̓^?oxlX-z8bMU*UԢ-~ٯVtrC;Jѱt}.)z h7oNE.:C^>1@Ҧfmj*t :lS )izt|{gw!;nj;7+ׅXR6[--*&ِ6DiOyȐTqCNԁD “2t% 83B (j&ۍl33{ATmQ4˾@t n[E#d BhUs AT/:_{=/J����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������FileKeyHex.key��������������������������������������������������������������������������������������100644��023420��023420�� 100�14277043763� 16307� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������0123456789abcdeffedcba98765432100123456789abcdeffedcba9876543210����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Format200.kdbx��������������������������������������������������������������������������������������100644��023420��023420�� 4376�14277043763� 16167� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������٢gK����1qCPX!jZ���� �! *|{6Lx\d*r+gMI �SA5ٳ[B\2zb-fmSL�p�������D+VZ>K7 �W<n`lTBnFp(bzb �W2oU >B6: MU|'^ ������ g^)Ϟ_,5B1'ARLNH;)y�U4R 71D)-ձy1|Oվp:)>jb,S]EaXHuԫUɅh0Z/p>9N+Fp@mxvWOc\ al=-pE{e?f4gd>< =ddW^jX5XҒjk`l54e~̼/7пh# YA[u@Se(?R2F $08BbHw̺7ЅwF,Ze`@ʁ'<5QYCo~% |bH`;'8!DD |�t3Dx9iT;Y4aS{/ؘΦcK341 5PjfF =pǹ:)i>LB[˹vJVĺϻ ^|M o1QmkDq\RKpƽR-wHPp^M43kC0 ]H^^kkH{klr%尊zy_O.{C;S@W͡x'"@H#Wu8@N#s]Ұ&,_YL2M*t=n%9 t;҃<ݑ K ćvm,I3V&HQdQ _RUƘ_6r@ ]YOא=�!05eA%ޒ+2~¥pW:PyIRZnmwNzpF.`w VG^?ĀкV5+a6 7kJœ:_DmV<f{kQ\ Wjʇ0fn! c>W) [̀!i"!4,HatYԬU!~ì ݴ%I\;q48 Cl!퇚Gdl h+<)փ'%C<UGuG򞈊,"U&'; |/\L~9Iq2`NL4 C'�=DzF3\ᙣeleln}/XhtVvg eXGtӰ}o23eHӹ_\{n"Yk 'Kp)AO܋P Qq04v n. 9\7l;zÿiq"N�oßcs#nW{0P@[:3SGy8UYRVv+ PA0wT. Lִs!ǜ"Wk/`gUP#s"I %|l r % xIUvwEރZdǧ׿; TZq L}AhyTd\D:BseY8Q?"̏+�ch �š`kkX3iDIX3*BzGt$E"sef=a-Fr<-ГGKefZvs}<Gy(ȷP5r}gڛ. �=NLce&Ɣ[zg NA=ӟ-*ę G Hd^0]Z^wZ?tP0A4W0xTbuUhC NG"k#mLnwʂB<-/eu^E*\5 "R_ 3͏LAX;Xمj\xJaʼX$qHX­s"�'!)v a? Pl ^@g vZ;(U,RmuT' PN4]j$7G_>ː:-cy7X b{逝A꩘dh������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Format300.kdbx��������������������������������������������������������������������������������������100644��023420��023420�� 3736�14277043763� 16167� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������٢gK����1qCPX!jZ���� �Z3-pnM<Ekp"ysfw  �o(m C{K M|~PJ@A�p�������29Pƫ � 8Ҵi+tBmU%A �jI1_V"EBϚK.Pb/ ������ ZڠOuz>ҬMf[! S'[/@KA|YVJw|> isQdhcA<f 4dx;aVo>P.!;,mgOx҅+U!RT+ ,k6iL=n}HB&;q݉N-&10(Eu[nmϡj1tI+SsĚR忋IH*1BS )!/С]P: ֺ( ^'Y:N|SOb=r0 \9iԛeNgmyاKA JLńjV"П34Zƌp߂=miyu~k<K0|w15`yVFhk܈Q7`U'磏Rl!2BU|Vآ:%3KUC 1+GVIEtf<R3:J@>e:q~:ȇ'+Ox'a2U1QnJ:4iB0BψRufmYƆqS ލւ;5<dp`JxgM"L3\d[^'׈L,-f]7.n'PF*l-HyNUt{k\ ϷL{K}6ͥ^$ˑjz~֚D ,(5p{}N[ ;";yTCKfsu;�¼�Ur|cA_$$NὉZ`N14q~,U&rePY L-a˃&;fvPm#( 4 aYC LH;vzGkk˻n_c…Llp(""-\=BuaCɜ"KH]eqX $2l�w61ʙt&0 L"mT{S]P--, i `مL=xY.^�Nu˽f@A/,3HN73_%Њv?S!յg!rJ"[|"rVa96;G諿 4 ׅFWM'uw'W£#I6.�C71uzq/Y% 6>¹J%@L`V+,#˒Ș 9Y-d A0LLPsc!wEB=B;[3Mc~}t*ӂ #fCvfKL,tM<'*ISRE"P[]r<f̵ "+3#K scJV4| T ~"s:6+:d9N0?k!!T~ft3�;9a\z.w v_t'+8 #K/uы]ߕUC0}T,F&KDCT2EEޗvhTI :jU5{st0k,9`'D2\״!0Oͬ]o@Cw]�DJYXAm0 ϐln^!aw%˛[Ѡn'*hoUX Lp,t3w:r;Evxɑ9q]e8ߺr{̕͹{Cå @¼= {E2 BOŮ7њLiFeؼ=Ty3/����������������������������������Format400.kdbx��������������������������������������������������������������������������������������100644��023420��023420�� 3411�14277043763� 16156� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������٢gK������+oL$31۵������ ���;yyS%1uY3hR,a¹ ����B���$UUID���cmߌ)DK ���V���������I�������������M�������������P������B���S ���Vm-* �:4A )}P٥� ���3?Porh0���� ݄i�ݏРRm牻ss\=$~9Ii !A2,vtkYp ^ a~ ��ōQtŗN::Z;q4L>ݨ* YwFuhv iN6�J@[9ZivU|E<רϨt$jT7!/qQg*@37ЩFF -]1/3rVnX*#Nt576tir a3@pV1eYm !ĊT7)vaN/\ט<8_X\%X?TTEDg�mꟚk$% A!2@ O05.k Qd`<x>?ɈM\gA^PbV=P2DVM6Ϙ],@G$G݆(T VoUzƚ66վ}U^Xjc;kjSȷ,+񐚹̂5aen) 5 j^Ƭs xb鰿Z0:zr!KmO6'~Ӄ|3 5ʪI:wYsq[T6K5>(v7(bTq=]p_YviPQge>5xި<Tr?Ƀe|b^Ofv '< \YP4|üca\lcJ/ lwon<IFGӶKeUH2E#$ogF 52?pUzPkɭYldrfz$pJ a;0:hvK+4g`8#iGS:W"WGϒT#bTz aȾ�Ea&LsV2vyN ˧Υ1|?A zXͩk,|quM׹`djSk'tU0QHrAS58tq1tА@Y<],7[yn@f3mjҘUTBOJ| рb=딾 bwmnMޕo F Fy9wBe}*׷ףɘ5iX]cKQJC]հ@Wo { ;AL= ~j}S̝7 &ͻQal`MH;|WI7g3QVbu9G۵@ +;ߵhS(&σfSzOCkpz^a7NJugc&m2D-AEڮL5́+k &NworZwu-l'หW C,O@3?#))[cI[ČR6XݓXgzFpn|Ve:: �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ykchalresp������������������������������������������������������������������������������������������100755��023420��023420�� 2124�14277043763� 16473� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files/bin��������������������������������������������������������������������������������������������������������������������������������������������#!/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; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������xmlv1.key�������������������������������������������������������������������������������������������100644��023420��023420�� 337�14277043763� 16350� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files/keys�������������������������������������������������������������������������������������������������������������������������������������������<?xml version="1.0" encoding="UTF-8"?> <KeyFile> <Meta> <Version>1.0</Version> </Meta> <Key> <Data> OF9tj+tfww1kHNWQaJlZWIlBdoTVXOazP8g/vZK7NcI= </Data> </Key> </KeyFile> �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������xmlv2.key�������������������������������������������������������������������������������������������100644��023420��023420�� 426�14277043763� 16350� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files/keys�������������������������������������������������������������������������������������������������������������������������������������������<?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> ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������pod-syntax.t����������������������������������������������������������������������������������������100644��023420��023420�� 252�14277043763� 16473� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/xt/author����������������������������������������������������������������������������������������������������������������������������������������������#!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(); ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������pod-no404s.t����������������������������������������������������������������������������������������100644��023420��023420�� 527�14277043763� 16201� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/xt/author����������������������������������������������������������������������������������������������������������������������������������������������#!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(); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������00-report-prereqs.dd��������������������������������������������������������������������������������100644��023420��023420�� 14730�14277043763� 16274� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t������������������������������������������������������������������������������������������������������������������������������������������������������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::Cipher::AES' => '0', 'Crypt::Digest' => '0', 'Crypt::Mac::HMAC' => '0', 'Crypt::Misc' => '0.049', 'Crypt::Mode::CBC' => '0', 'Crypt::PRNG' => '0', 'Crypt::Stream::ChaCha' => '0.048', 'Crypt::Stream::Salsa20' => '0.055', 'Data::Dumper' => '0', 'Devel::GlobalDestruction' => '0', 'Encode' => '0', 'Exporter' => '0', 'File::Temp' => '0', 'Hash::Util::FieldHash' => '0', 'IO::Handle' => '0', 'IPC::Cmd' => '0.84', 'Iterator::Simple' => '0', 'List::Util' => '1.33', 'Math::BigInt' => '1.993', '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::Local' => '1.19', 'Time::Piece' => '1.33', 'XML::LibXML' => '0', 'XML::LibXML::Reader' => '0', 'boolean' => '0', 'namespace::clean' => '0', 'overload' => '0', 'perl' => '5.010', 'strict' => '0', 'warnings' => '0' }, 'suggests' => { 'Crypt::Stream::Serpent' => '0.055', 'Crypt::Stream::Twofish' => '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', 'Math::BigInt' => '1.993', 'Test::Deep' => '0', 'Test::Fatal' => '0', 'Test::More' => '1.001004_001', 'Test::Warnings' => '0', 'lib' => '0', 'utf8' => '0' }, 'suggests' => { 'POSIX::1003' => '0' } } }; $x; }����������������������������������������Cipher.pm�������������������������������������������������������������������������������������������100644��023420��023420�� 21553�14277043763� 16237� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������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.906'; # 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.906 =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; Called by L</new> to set attributes. You normally shouldn't call this. Returns itself to allow method chaining. =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 �����������������������������������������������������������������������������������������������������������������������������������������������������Dumper.pm�������������������������������������������������������������������������������������������100644��023420��023420�� 27537�14277043763� 16271� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������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.906'; # 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}; my $mode = delete $args{mode}; my $uid = delete $args{uid}; my $gid = delete $args{gid}; my $atomic = delete $args{atomic} // 1; $args{kdbx} //= $self->kdbx; my ($fh, $filepath_temp); if ($atomic) { require File::Temp; ($fh, $filepath_temp) = eval { File::Temp::tempfile("${filepath}-XXXXXX", UNLINK => 1) }; if (!$fh or my $err = $@) { $err //= 'Unknown error'; throw sprintf('Open file failed (%s): %s', $filepath_temp, $err), error => $err, filepath => $filepath_temp; } } else { open($fh, '>:raw', $filepath) or throw "Open file failed ($filepath): $!", filepath => $filepath; } $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]; if ($filepath_temp) { $mode //= $file_mode // do { my $m = umask; defined $m ? oct(666) &~ $m : undef }; $uid //= $file_uid // -1; $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 _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 < KDBX_VERSION_OLDEST || 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.906 =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 dump another KDBX file. =head2 dump $dumper->dump(\$string, %options); $dumper->dump(\$string, $key, %options); $dumper->dump(*IO, %options); $dumper->dump(*IO, $key, %options); $dumper->dump($filepath, %options); $dumper->dump($filepath, $key, %options); Dump a KDBX file. The C<$key> is either a L<File::KDBX::Key> or a primitive castable to a Key object. Available options: =over 4 =item * C<kdbx> - Database to dump (default: value of L</kdbx>) =item * C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>) =back Other options are supported depending on the first argument. See L</dump_string>, L</dump_file> and L</dump_handle>. =head2 dump_string $dumper->dump_string(\$string, %options); $dumper->dump_string(\$string, $key, %options); \$string = $dumper->dump_string(%options); \$string = $dumper->dump_string($key, %options); Dump a KDBX file to a string / memory buffer. Available options: =over 4 =item * C<kdbx> - Database to dump (default: value of L</kdbx>) =item * C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>) =back =head2 dump_file $dumper->dump_file($filepath, %options); $dumper->dump_file($filepath, $key, %options); Dump a KDBX file to a filesystem. Available options: =over 4 =item * C<kdbx> - Database to dump (default: value of L</kdbx>) =item * C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>) =item * C<mode> - File mode / permissions (see L<perlfunc/"chmod LIST"> =item * C<uid> - User ID (see L<perlfunc/"chown LIST">) =item * C<gid> - Group ID (see L<perlfunc/"chown LIST">) =item * C<atomic> - Write to the filepath atomically (default: true) =back =head2 dump_handle $dumper->dump_handle($fh, %options); $dumper->dump_handle(*IO, $key, %options); $dumper->dump_handle($fh, %options); $dumper->dump_handle(*IO, $key, %options); Dump a KDBX file to an output stream / file handle. Available options: =over 4 =item * C<kdbx> - Database to dump (default: value of L</kdbx>) =item * C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/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 �����������������������������������������������������������������������������������������������������������������������������������������������������������������Loader.pm�������������������������������������������������������������������������������������������100644��023420��023420�� 24335�14277043763� 16234� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������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.906'; # 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 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.906 =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 and store the result in L<File::KDBX/raw> without parsing =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, %options); $kdbx = File::KDBX::Loader->load(\$string, $key); $kdbx = File::KDBX::Loader->load(*IO, %options); $kdbx = File::KDBX::Loader->load(*IO, $key); $kdbx = File::KDBX::Loader->load($filepath, %options); $kdbx = File::KDBX::Loader->load($filepath, $key); Load a KDBX file. This works as an instance or a class method. The C<$key> is either a L<File::KDBX::Key> or a primitive castable to a Key object. Available options: =over 4 =item * C<key> - Alternative way to specify C<$key> =back =head2 load_string $kdbx = File::KDBX::Loader->load_string($string, %options); $kdbx = File::KDBX::Loader->load_string($string, $key); $kdbx = File::KDBX::Loader->load_string(\$string, %options); $kdbx = File::KDBX::Loader->load_string(\$string, $key); Load a KDBX file from a string / memory buffer. This works as an instance or class method. Available options: =over 4 =item * C<key> - Alternative way to specify C<$key> =back =head2 load_file $kdbx = File::KDBX::Loader->load_file($filepath, %options); $kdbx = File::KDBX::Loader->load_file($filepath, $key); Read a KDBX file from a filesystem. This works as an instance or class method. Available options: =over 4 =item * C<key> - Alternative way to specify C<$key> =back =head2 load_handle $kdbx = File::KDBX::Loader->load_handle($fh, %options); $kdbx = File::KDBX::Loader->load_handle($fh, $key); $kdbx = File::KDBX::Loader->load_handle(*IO, %options); $kdbx = File::KDBX::Loader->load_handle(*IO, $key); Read a KDBX file from an input stream / file handle. This works as an instance or class method. Available options: =over 4 =item * C<key> - Alternative way to specify C<$key> =back =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 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Object.pm�������������������������������������������������������������������������������������������100644��023420��023420�� 66350�14277043763� 16237� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������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.906'; # 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 taken immediately 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.906 =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. Throws if the object is disconnected. Other object methods might only work if the object is connected to a database and so they might also throw if the object is disconnected. If you're not sure if an object is connected, try L</is_connected>. =head2 uuid 128-bit UUID identifying the object within the connected 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 connected database. =head2 tags Text string with arbitrary tags which can be used to build a taxonomy. =head2 previous_parent_group 128-bit UUID identifying a group within the connected database the previously contained the object. =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. =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, just like cutting off a branch takes the leafs 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. It is a set of key-value pairs used to store arbitrary data, usually used by software like plug-ins to keep track of state rather than by end users. 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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Compressed.kdbx�������������������������������������������������������������������������������������100644��023420��023420�� 3676�14277043763� 16623� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������٢gK���1qCPX!jZ���� �6m14To3 �!hxnVβZl?㠰ղiyV�p�������Z(x :S �+۬YD,:ç $gJ;U �i%Ln Qt⃃Eڿ a#~ ������ ]w)Xշ@x1z[r"W5#l^"1eR 4KH7'.4ה8YO_k0 UEKu@s5SY_0KcXa8f5T{'l/`bbH!$WocO)ԮOsם01 m,Jh>Sq}~'J;#azjz#>C,e](@6BB;Hz#YK&ڮ5#}7i]=;Yjw!&2dtԀRsVosV4A , ײ{Pe^+�D$ϝe#0!k:fX)-<s!&FQGcq5㈮*\+M۷@Y˴FWe/RnĮC'v-]a>w ukG(%JFIK)ˑ Cp .Gї79,SPH*lZN(1B8$m 5?%-m,íǓ�a_p<'158[e dJB2T~#3ʸJ cEDp[ Ȅ ! ʌ"u~crP#g៵Fc�<饏P^$l[ UrO(eNHwAz8ܙB|]UK`Hq7 py/~ })ڃUI F\ؓͅd&sxkʼnIRH kgzu ZH? D�lڥ@l5"Ek:\1(Y .WρdmZv\Z A!/)])y<P._ɲwdKOOfhiM3<1iƉ:sڹ|Ya`;]? Ŀ8Mezuƨ@v/CEa(/Kr3�7&fNP,7aZm_i *䱇Q@r M"vz<ptwWe#H\4\ӡV3_Rle&s6ɚ=YͽL Q]T\R;ť[mufd)& -*YHup9dLs${HjJ-&Ѻ\ӒA`-2Pabeg,]̯L{끈ѣ_CeU[+rnQ@V ل#=>w[M_;:1:݊W1 C+p5}y#K7C Bݱ=k7*C (eJ\OV0{Wy*R*P[բZ@.X>o"[%Py*}{Ax- x4I7hzeo}5`}ߤ"U.^JT)|D{P1Ot/ q3M[PtZp[qC{uYLjԏ<uFiB'9i{Ӑވ<<"/F޸|]'`S|< !` ,zƗ9=%�J c>7d'jP6$y5*>+M՜͍pBfr Ґf>0/!ݼsgxs�1B@!r-Uq'������������������������������������������������������������������FileKeyHex.kdbx�������������������������������������������������������������������������������������100644��023420��023420�� 3116�14277043763� 16501� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������٢gK���1qCPX!jZ���� �JKrG]濵YPEE �iYN*7N#I!֙K Gz�p�������.@ª( �΄0Wp*[-߼<^>]{ �ⶓtk^fڳU<SE"/ ������ ʬ%ʬNFdT-@..874WZn- YoVԕ[wܽ1 5J~^OGhD-B+M/A&lΐGěKq0 =+;cs= XM+Fu%T;x,0cG*ck/sT[Keծ[hؒӏc^6ZCJP>Z)˵/:J[`64l:n<BhoM]erfl\l G{Yl,<D<ҧ?OexģY8n'1ݿf`/Z#NjJ4*kdc8+!_2qUS1K,\s(n!hY_G] \GY*ǜwS/xt-iN2ACS͆5K5Z!쒏mqC4kx" kȥq#?UX0OBoB~3OHB~ ekw~)&اGdB?_ /lg`xK$RZϺ (] i@i!mFRҿGv䷷| [X֭M;P6:?yjXVN*.&b(*fW 9{s�rv ? hܪL�݌霔'mOZ[ުvT)M=ӳ(W *1&dM[-vUD1 qRN(&J q8 h ~|i@|Ϳ:ɗ m.[Llz`V|g9ՑBh%<RPʨqZ~lcJV4+%l[B<SƠjv4ToQ-fpry 6*[g&|ԖS)5NCHߞЭC@L  'cwF�0nD){ij׆D|G,_sq ÙcWHVZ{ d8wiƆ~Sn"> �ζglsD(f ١Ӛ T2g j>74gE{ZX-0 )L0z}'I&T~zfDv$6džڏvD@.�Uq4 l3{"\j$F3]jmHb`r.%*6p׏LraS46RfvWrqFD+ bR%]-uFYoѿçӶZ)f [Xq]Jil$2Hf`|u5��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������binary.key������������������������������������������������������������������������������������������100644��023420��023420�� 40�14277043763� 16534� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files/keys�������������������������������������������������������������������������������������������������������������������������������������������BY wJ׎A/ }=dI������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������hashed.key������������������������������������������������������������������������������������������100644��023420��023420�� 24�14277043763� 16506� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files/keys�������������������������������������������������������������������������������������������������������������������������������������������We are all Satoshi. ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������portability.t���������������������������������������������������������������������������������������100644��023420��023420�� 267�14277043763� 16735� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/xt/author����������������������������������������������������������������������������������������������������������������������������������������������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(); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������KDF�������������������������������������������������������������������������������������������������000755��023420��023420�� 0�14277043763� 14705� 5����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������AES.pm����������������������������������������������������������������������������������������������100644��023420��023420�� 10410�14277043763� 16027� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/KDF��������������������������������������������������������������������������������������������������������������������������������������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.906'; # 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.906 =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 ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������CompositeKey.kdb������������������������������������������������������������������������������������100644��023420��023420�� 1174�14277043763� 16731� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������٢eK�����}BuU~ ߏ OAjq������MXNNjz؆GٰB-`<'0"x pVVd���A(*_ԙe3/gb%+Þ,fx3?f_EO sŭ 8p ֽSՄE<)0"RMR0oX_ꭡ ͅb?j[}k(ɻ⫪ܙVv psԡkLDI;" W='xRDš{5Vd4-1[G$"F_vՃGHƟh \c s4)h$KG$dHT*C09fM{})V1ܐ4c4zgOen˯;L�~!C#!)\A,lTpW*`A  7z N\ķP , &96qWy|^?*2>pBQ 4Í6،v2ڨ ih"=$"I ZWkICQh>lB'Lp`yp?(^$blI ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������pod-coverage.t��������������������������������������������������������������������������������������100644��023420��023420�� 334�14277043763� 16741� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/xt/author����������������������������������������������������������������������������������������������������������������������������������������������#!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' }); ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������IO��������������������������������������������������������������������������������������������������000755��023420��023420�� 0�14277043763� 14610� 5����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������Crypt.pm��������������������������������������������������������������������������������������������100644��023420��023420�� 10431�14277043763� 16426� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/IO���������������������������������������������������������������������������������������������������������������������������������������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.906'; # 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.906 =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 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Iterator.pm�����������������������������������������������������������������������������������������100644��023420��023420�� 27707�14277043763� 16625� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������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.906'; # 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.906 =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 by 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</order_by> which might be useful in the context of KDBX databases which are normally pretty small so draining an iterator completely isn't cost-prohibitive in terms of memory usage. 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 L</next> is equivalent to calling the iterator without arguments. =head1 METHODS =head2 new \&iterator = File::KDBX::Iterator->new(\&iterator); Bless 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); 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 # Replace buffer: $iterator->unget(\@items); # OR equivalently $iterator->(\@items); # Unshift onto buffer: $iterator->unget(@items); # OR equivalently $iterator->(@items); Replace the buffer (first form) or unshift one or more items to the current buffer (second form). 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. This method has 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 available as 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(sub($item) { ... }); Get a new iterator draining from an existing iterator but providing only items that pass a test or are matched by a query. In its basic form this method is very much like perl's built-in grep function, except for iterators. There are many examples of the various forms of this method at L<File::KDBX/QUERY>. =head2 map \&iterator = $iterator->map(\&code); Get a new iterator draining from an existing iterator but providing modified items. In its basic form this method is very much like perl's built-in map function, except for iterators. =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 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 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> is 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). KDBX databases are always fully-loaded into memory anyway, so there's not a significant memory cost to draining an iterator completely. =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 ���������������������������������������������������������Key�������������������������������������������������������������������������������������������������000755��023420��023420�� 0�14277043763� 15031� 5����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������File.pm���������������������������������������������������������������������������������������������100644��023420��023420�� 26140�14277043763� 16431� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/Key��������������������������������������������������������������������������������������������������������������������������������������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.906'; # 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 $atomic = $args{atomic} // 1; my $filepath_temp; if (!openhandle($fh)) { $filepath or throw 'Must specify where to safe the key file to'; if ($atomic) { require File::Temp; ($fh, $filepath_temp) = eval { File::Temp::tempfile("${filepath}-XXXXXX", UNLINK => 1) }; if (!$fh or my $err = $@) { $err //= 'Unknown error'; throw sprintf('Open file failed (%s): %s', $filepath_temp, $err), error => $err, filepath => $filepath_temp; } } else { open($fh, '>:raw', $filepath) or throw "Open file failed ($filepath): $!", filepath => $filepath; } } 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.906 =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 from L<File::KDBX::Constants/":key_file">: =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>) =item * C<atomic> - Write to the filepath atomically (default: true) =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 ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������FileKeyBinary.kdb�����������������������������������������������������������������������������������100644��023420��023420�� 1174�14277043763� 17013� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������٢eK�����9`g⸢ʩM5yW7ȏU{l������@Xm!+HT�L\lfՕraG)4$/§j8QP��&*근+97=}"Jb"B(]k~T_4~C *lQ!D/ӛ"/7q튶 /Lrg*D r9O}@ 0~lc07VksT\'1y7Ol י/djؑ2VzMh2S O\| ygg4 +(1S<:הi/À2y_˧o+ւi <.rT-h*bH] Uoz.*w9XE~*]$p M& >^1c)_$6vF"*n1lZR h}JP{}1纙xx izu<ģq�R։$)h8$-uB,dRs:S ^f5mj^+Ջ+pO_Jxęffg#Y~?>^k2l[kZnZ9Q6"9z28')Q"y,/>?.⬉NS����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������FileKeyBinary.key�����������������������������������������������������������������������������������100644��023420��023420�� 40�14277043763� 16772� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������  !"#$%&'()012������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������FileKeyHashed.kdb�����������������������������������������������������������������������������������100644��023420��023420�� 1174�14277043763� 16763� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������٢eK�����#87淘4 V/K*\ a������[;Li4C@pQ`Ot! ;H`%9UVs~<mSb_q P��tF>.EWh;v-DQh;/UvE{c&-C#@ۍޒ8`E{:4\ŵt︌Jk5Z ʼn2ar;!liTZ2>ת}!RkmG}bgN!=^4 v+5IENo\^S,5` eThyOap Pg>h l8Kc=:Cҏnݗ+Z2pVV2CnPsZ-?ƥݪ9gDNe)ESB?M,ΣeSn ݘ-=7ςepS&}EƛlrO?H&-[ 2lbcf[?2}6f*+ x(;:>W>XxjSâYaۛϪ"|o/gk0bL\8&1'c]fr!0 k,?tC����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������FileKeyHashed.key�����������������������������������������������������������������������������������100644��023420��023420�� 3240�14277043763� 17007� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������PNG  ��� IHDR������A���ܝ���sBIT|d��� pHYs����+��BIDATx_HSm9\Z لDEeJVB) KEMuEAxBPHa àQ^Nn{tg{<D$!D}O $J $J $J $J $J $J $J $J $J $J $J $J $J i4MԩS4 ҥKrbnǒ%K{n dm^v MӰ}}$QUUMzg2�Flnn&�v޺u+S؃js8|YVOehhs%�޹s'nߕ+Wn@`:#kBܵk0//T{|lB�ܼys{H�XXXȱ1wK�J0 +++ .>/SXaa30 Z�x1r`SSlgx0~ʵkךW۷od~~>srrb 8q`k Ϲo>z<v\.VWW;X0xUVTTpѢEt8,((`]]?~lf*GMh۹~ҥK'?`�KJJ844T799ɽ{N(++3OP:S{ n%Ӎi޽k555͸vZqs>}}�`�ϟu@N~|Wɓ'ӮM!s۶m|! #GFFxe`yyYG�<s GFFDŚ5|B] gZƃQXXH�f8N[~=7i߇iN!l6n˗q?y򄵵tݴq͙3Ǭ+))!�üq߿7DǏ7?>GGGge<~n�X[[H$Wl6m6u]4-Nvjܾ};nlٲ[no,LK]iٸzj`cc_lSɛ7o`={FͺcY-fRZZJ�liig("IK9ac[[9o<M$uXkk+~?N''ͳ=Y{100|j$I[�ŋcSa:"޽{ƈ\.W5E5k811A<}44vdgy崴$o޼Iv~ ~:7lؐvt=\Ҽb�N.^8iM64 p?VjH~y(2{:_j0HǼ%9r$y!˷tj#1qkllvLvA5@s%#3H>}xֳ' n뻵蓼zz<:沬G`Vk#ŋ,..dQQϞ=K0gss3/_N rƍv횹vR@�[sMz ;vH;dF1C(I0C(I0C(I0C(I0C(I0C(I0C(I0C(I0C(I0C(I0C(:b����IENDB`����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������release���������������������������������������������������������������������������������������������000755��023420��023420�� 0�14277043763� 14177� 5����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/xt�����������������������������������������������������������������������������������������������������������������������������������������������������cpan-changes.t��������������������������������������������������������������������������������������100644��023420��023420�� 344�14277043763� 17034� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/xt/release���������������������������������������������������������������������������������������������������������������������������������������������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'); }; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Constants.pm����������������������������������������������������������������������������������������100644��023420��023420�� 62340�14277043763� 17000� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������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 5.010; use warnings; use strict; use Exporter qw(import); use File::KDBX::Util qw(int64); use Scalar::Util qw(dualvar); use namespace::clean -except => 'import'; our $VERSION = '0.906'; # 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 => int64('62135596800'), }, 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.906 =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 to 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 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Dumper����������������������������������������������������������������������������������������������000755��023420��023420�� 0�14277043763� 15535� 5����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������V3.pm�����������������������������������������������������������������������������������������������100644��023420��023420�� 13630�14277043763� 16546� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/Dumper�����������������������������������������������������������������������������������������������������������������������������������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 :int :load erase_scoped); use IO::Handle; use namespace::clean; extends 'File::KDBX::Dumper'; our $VERSION = '0.906'; # 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; my $got_iv_size = length($headers->{+HEADER_ENCRYPTION_IV}); alert 'Encryption IV should be exactly 16 bytes long', got => $got_iv_size, expected => 16 if $got_iv_size != 16; 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) { $val = pack_Ql($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'; $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.906 =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 ��������������������������������������������������������������������������������������������������������V4.pm�����������������������������������������������������������������������������������������������100644��023420��023420�� 27424�14277043763� 16555� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/Dumper�����������������������������������������������������������������������������������������������������������������������������������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 :int :load 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.906'; # 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+$/) { my $neg = $variant < 0; my @b = unpack('L>2', scalar reverse pack_Ql($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) { $val = pack_Ql($val); } elsif ($type == VMAP_TYPE_BOOL) { $val = pack('C', $val); } elsif ($type == VMAP_TYPE_INT32) { $val = pack('l', $val); } elsif ($type == VMAP_TYPE_INT64) { $val = pack_ql($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 $got_iv_size = length($kdbx->headers->{+HEADER_ENCRYPTION_IV}); my $iv_size = $cipher->iv_size; alert "Encryption IV should be $iv_size bytes long", got => $got_iv_size, expected => $iv_size if $got_iv_size != $iv_size; 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.906 =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 ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Loader����������������������������������������������������������������������������������������������000755��023420��023420�� 0�14277043763� 15507� 5����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������V3.pm�����������������������������������������������������������������������������������������������100644��023420��023420�� 12510�14277043763� 16514� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/Loader�����������������������������������������������������������������������������������������������������������������������������������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 :int :io :load erase_scoped); use namespace::clean; extends 'File::KDBX::Loader'; our $VERSION = '0.906'; # 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) { ($val) = unpack_Ql($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.906 =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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������V4.pm�����������������������������������������������������������������������������������������������100644��023420��023420�� 20651�14277043763� 16522� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/Loader�����������������������������������������������������������������������������������������������������������������������������������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 :int :io :load erase_scoped); use File::KDBX::IO::Crypt; use File::KDBX::IO::HmacBlock; use boolean; use namespace::clean; extends 'File::KDBX::Loader'; our $VERSION = '0.906'; # 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) { ($val) = unpack_Ql($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) { ($val) = unpack_ql($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.906 =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 ���������������������������������������������������������������������������������������FileKeyBinary.kdbx����������������������������������������������������������������������������������100644��023420��023420�� 3056�14277043763� 17204� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������٢gK���1qCPX!jZ���� �h (RV澌 4sW ��z1-pX%3se@(AK~\�p�������4٦CA G*vf �?4QaedcZLAR J � c'KüCbÈKw�y[LX1 ������ Yik,,Ns%>ZMgCl⎳d_θU銅n@(ͳIeM Qz :wqUVȖ( {!6j=ؼ=}vY%i6I9%A2d;eu ieȋ:e xS#%cQPTgޢY ޹Dm;lr|ףcsz~,2FWJm "Kh1.8Q4E_xL}@fvvIDғT_�dَyT3\`[7%1H0L=LUwdt1ZҀ)Эoa0WLכ*"TxHpu{ 4Vb:󩱧 :#К]&CDߊWhn8oU@ah-6hE)SIYFz՚ѧuZ|ࢤڤMU+uya]&V7쎰 hŸFI76q?^]XЮ#ȷ gLmT!KFUY׏drW(OBbVawB4eoң XqeBRB𯂝sXqq-'T6{>o7%h%Bde(\' &LljjK y\9b~I%:s%JfA]>ލ#4 4P=}HKw_7=Ձ%(Bt.x4Qb<O(pb`3Cw= 8 ,3sF(TMQ_zah҈ss🎽ʠ7}C~fi,Mp^GQ~:ҵ]%*`K^,EɑiorEdDewP!ty6v+Կ7A()h0.>AxY*O9�)n΃IHqXЏM:*�N t6pcHgzxЂz l'i1)qGi$Ϊ{/'9J+"q0xTJG#-;8LNFj&s#[)yJ&s&j@lٯ |oڕ +ՙe^A.yr)tbKGۮP5mN֔ C/PP:؇ `8ۮt|\Gi$hr]a9>%7 ]$ՙA5v+RI4T r5~@]"&]>o V5dڪ|urC瑞hcu����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������FileKeyHashed.kdbx����������������������������������������������������������������������������������100644��023420��023420�� 3056�14277043763� 17154� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������٢gK���1qCPX!jZ���� �aX_b)TVP�FRTsE&:1C �wY2E6|Uub 3>�p�������%+iyrK �)vo":kz9JMπ٦$ �7UOŔKcQO. ������ 1?6 K晡@=h[pnz+[,7Կ _Ҵر-\Lzړ\I3ܘ;9ޝC_ݥ,1Mx;xب]l(!.'HDKcu ֊jO2D%2CgA0TLT '{f'0c J7[.n#P;`ĴWO 庖 CBms1<|c[:>Brb' .oJĖwd U+{dj+}K,Id �Ri@U;蒗z|lI#373%tBë\k񏫓ŀy5`gj_\ژo#NSAGlÚx:L; 1SޙY4h`A;&3#=m2>"ThWu"֓"-0z^&@!kƖD,P\z;ZI|%Iǘ84mgG$Z2h~ы Ep427&=t\R@i"#گ с.l9^OP&]JD.ĉs͌WR]#VBCgoLo~2lxzaHðFC ّ;Y S`HJǞ K:B;y 'g>,dTpx&I v[DAӐ|'_eU3N.w}-aWoԘvp9θ@[Ӓٿ^0G1VɘCmAF .f.MI;Wg"KNT͗&rV^G Fķb|}Jç ujrB 3is?:Ϭ*"|`ڹW 枸2BrH "3 u!SԪt>AFeU*Ֆ(S:NxxXyWm!`TUk�+w# :'qL -{G_ZyҺokb {u=叽2@XB]|zv:m7_#LsԱcg 9z t-h!xC�oaR `]/tMtU̩tRy/kJ˅LlnB)?:Hm&}f(DH6ϋ~q}7�ӏUE&葫_Y[hG~=id[,E ۏ\=IO>LՒݕOrx~۽7 1jL0e3C7t;3X:�ku- ׸c)0?v% 4De����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Cipher����������������������������������������������������������������������������������������������000755��023420��023420�� 0�14277043763� 15513� 5����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������CBC.pm����������������������������������������������������������������������������������������������100644��023420��023420�� 3776�14277043763� 16615� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/Cipher�����������������������������������������������������������������������������������������������������������������������������������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.906'; # 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.906 =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 ��KDB.pm����������������������������������������������������������������������������������������������100644��023420��023420�� 10135�14277043763� 16653� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/Dumper�����������������������������������������������������������������������������������������������������������������������������������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.906'; # 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); 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.906 =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 �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Raw.pm����������������������������������������������������������������������������������������������100644��023420��023420�� 4105�14277043763� 16764� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/Dumper�����������������������������������������������������������������������������������������������������������������������������������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.906'; # 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.906 =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 �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������XML.pm����������������������������������������������������������������������������������������������100644��023420��023420�� 45714�14277043763� 16726� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/Dumper�����������������������������������������������������������������������������������������������������������������������������������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 :int erase_scoped gzip snakify); use IO::Handle; use Scalar::Util qw(blessed isdual looks_like_number); use Time::Piece 1.33; use XML::LibXML; use boolean; use namespace::clean; extends 'File::KDBX::Dumper'; our $VERSION = '0.906'; # 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; my $seconds_since_ad1 = $_ + TIME_SECONDS_AD1_TO_UNIX_EPOCH; my $buf = pack_Ql($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.906 =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 not 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 ����������������������������������������������������Argon2.pm�������������������������������������������������������������������������������������������100644��023420��023420�� 6652�14277043763� 16544� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/KDF��������������������������������������������������������������������������������������������������������������������������������������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.906'; # 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.906 =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 ��������������������������������������������������������������������������������������KDB.pm����������������������������������������������������������������������������������������������100644��023420��023420�� 41504�14277043763� 16631� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/Loader�����������������������������������������������������������������������������������������������������������������������������������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 1.33; use boolean; use namespace::clean; extends 'File::KDBX::Loader'; our $VERSION = '0.906'; # VERSION my $DEFAULT_EXPIRATION = Time::Piece->strptime('2999-12-31 23:59:59', '%Y-%m-%d %H:%M:%S'); 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.906 =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 ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Raw.pm����������������������������������������������������������������������������������������������100644��023420��023420�� 3502�14277043763� 16736� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/Loader�����������������������������������������������������������������������������������������������������������������������������������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.906'; # 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.906 =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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������XML.pm����������������������������������������������������������������������������������������������100644��023420��023420�� 43316�14277043763� 16674� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/Loader�����������������������������������������������������������������������������������������������������������������������������������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 :int :text gunzip erase_scoped); use Scalar::Util qw(looks_like_number); use Time::Piece 1.33; use XML::LibXML::Reader; use boolean; use namespace::clean; extends 'File::KDBX::Loader'; our $VERSION = '0.906'; # 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 $@; $binary .= \0 x (8 - length($binary)) if length($binary) < 8; my ($seconds_since_ad1) = unpack_Ql($binary); my $epoch = $seconds_since_ad1 - TIME_SECONDS_AD1_TO_UNIX_EPOCH; return gmtime($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.906 =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 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������minimum-version.t�����������������������������������������������������������������������������������100644��023420��023420�� 153�14277043763� 17523� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/xt/author����������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::MinimumVersion; all_minimum_version_ok( qq{5.10.1} ); ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������YubiKey.pm������������������������������������������������������������������������������������������100644��023420��023420�� 36424�14277043763� 17141� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/Key��������������������������������������������������������������������������������������������������������������������������������������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.84 qw(run_forked); use Ref::Util qw(is_arrayref); use Symbol qw(gensym); use namespace::clean; extends 'File::KDBX::Key::ChallengeResponse'; our $VERSION = '0.906'; # 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.906 =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, its 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 seconds. 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 interest. It would also be possible to implement this as 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 ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Transaction.pm��������������������������������������������������������������������������������������100644��023420��023420�� 3777�14277043763� 17302� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX������������������������������������������������������������������������������������������������������������������������������������������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.906'; # 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.906 =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 �clean-namespaces.t����������������������������������������������������������������������������������100644��023420��023420�� 565�14277043763� 17573� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/xt/author����������������������������������������������������������������������������������������������������������������������������������������������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; �������������������������������������������������������������������������������������������������������������������������������������������HashBlock.pm����������������������������������������������������������������������������������������100644��023420��023420�� 15115�14277043763� 17167� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/IO���������������������������������������������������������������������������������������������������������������������������������������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.906'; # 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.906 =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 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������HmacBlock.pm����������������������������������������������������������������������������������������100644��023420��023420�� 15026�14277043763� 17155� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/IO���������������������������������������������������������������������������������������������������������������������������������������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 :int :io); use namespace::clean; extends 'File::KDBX::IO'; our $VERSION = '0.906'; # VERSION our $BLOCK_SIZE = 1048576; # 1MiB our $ERROR; my %ATTRS = ( _block_index => int64(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 { 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_Ql($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_Ql($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_Ql($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.906 =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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Password.pm�����������������������������������������������������������������������������������������100644��023420��023420�� 2642�14277043763� 17335� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/Key��������������������������������������������������������������������������������������������������������������������������������������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.906'; # 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.906 =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 ����������������������������������������������������������������������������������������������BrokenHeaderHash.kdbx�������������������������������������������������������������������������������100644��023420��023420�� 3676�14277043763� 17654� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������٢gK���1qCPX!jZ���� �6m14To3 �!hxnVβZl?㠰ղiyV�p�������Z(x :S �+۬YD,:ç $gJ;U �i%Ln Qt⃃Eڿ a#~ ������ ]w)Xշ@x1z[r"W5#l^"1eR 4KH7'.4ה8YO_k0 UEKu@s5SY_0KcXa8f5T{'l/`bbH!$WocO)ԮOsם01 m,Jh>Sq}~'J;#azjz#>C,e](@6BB;Hz#YK&ڮ5#}7i]=;Yjw!&2dtԀRsVosV4A , ײ{Pe^+�D$ϝe#0!k:fX)-<s!&FQGcq5㈮*\+M۷@Y˴FWe/RnĮC'v-]a>w ukG(%JFIK)ˑ Cp .Gї79,SPH*lZN(1B8$m 5?%-m,íǓ�a_p<'158[e dJB2T~#3ʸJ cEDp[ Ȅ ! ʌ"u~crP#g៵Fc�<饏P^$l[ UrO(eNHwAz8ܙB|]UK`Hq7 py/~ })ڃUI F\ؓͅd&sxkʼnIRH kgzu ZH? D�lڥ@l5"Ek:\1(Y .WρdmZv\Z A!/)])y<P._ɲwdKOOfhiM3<1iƉ:sڹ|Ya`;]? Ŀ8Mezuƨ@v/CEa(/Kr3�7&fNP,7aZm_i *䱇Q@r M"vz<ptwWe#H\4\ӡV3_Rle&s6ɚ=YͽL Q]T\R;ť[mufd)& -*YHup9dLs${HjJ-&Ѻ\ӒA`-2Pabeg,]̯L{끈ѣ_CeU[+rnQ@V ل#=>w[M_;:1:݊W1 C+p5}y#K7C Bݱ=k7*C (eJ\OV0{Wy*R*P[բZ@.X>o"[%Py*}{Ax- x4I7hzeo}5`}ߤ"U.^JT)|D{P1Ot/ q3M[PtZp[qC{uYLjԏ<uFiB'9i{Ӑވ<<"/F޸|]'`S|< !` ,zƗ9=%�J c>7d'jP6$y5*>+M՜͍pBfr Ґf>0/!ݼsgxs�1B@!r-Uq'������������������������������������������������������������������MemoryProtection.kdbx�������������������������������������������������������������������������������100644��023420��023420�� 4005�14277043763� 20021� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������٢gK������1qCPX!jZ������ ���A *SVgRMH~ABTh{"ܩ^y��� 1oCo4{ ����B���$UUID���cmߌ)DK ���I�������������M�������������P������B���S ���M Z"&}lhiMF4׎ij���V����������� GM"3ZEN|٠{`*Oķ]In& Ueqy4)䑰%ږ{șn:Ϟ��JfDf)w!i٨`Jmx8f_L~{"K \xTgNehϜA=K(qz9 QޱdBt뱽@+tiT\LVz! - ׊ORTe"bt~[:_Ɋr)rM,T'>] b 6[V;xԡ1^oajUC=H1#Li@ER1'm31}A`G([og8v9XThgp'%fz锧¾Ml!Nm[?#C ^rAQۄ4mFKg| FAK1;fCԀހe.$Jdֲe@+�6mA)q~zأ'9g�`t5+pI ~_[?./̮edR$d7{2l-T?b8wBqc{Y :؍5i4ӟ]S'䘎漈A39JfI!r@AcѨ>ٜV"~)fv} nntsz̓թ <3DLMKQVUڨ�QH ԓCcӑ$mZ\lL_NF\`!*)&Y^pH[6. T&kLsk)Ems~`{FJͬuE8ʯ'7e1L&|2]*J/B Z~yg7Uv+%ʬTz&o q{˳Ԏ$/)wmn3t(q\`Ϊ,Ҁz㤻S3y>P0랞.ic%J$BI Jut:(V#(n<AP9v.s4<FǨ|;yqXB+R<(9*8e{Xܐ[zmA*s '[:ᰋ,ت>iT烳."_|/mPc$wqtxtᆈ"2rz}C b/Pm0XVC +)º\>ܽ}JY. 0IT@G9O~js@RG|JJ7}afHֺ%`<kz?"D3=[0}5޴$ɻD[iuZAc;̸lI~s^� pz4W; "#ht"P$+h`]731=k >ƏT6x6@jܻT;EH:.1{fP2L0UPW.qR 9(-V7-MmYη4E0uAԸp~[h'p6Ȃ}.cr6e?:o Czuހ,wj-z1Tbz[;wfӿuuW@1&= 6tNXEXT�Y#+s즫5˛)^xsIzP3`HcLu0UzAKn ӄI}m*;9yktGa�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ProtectedStrings.kdbx�������������������������������������������������������������������������������100644��023420��023420�� 3716�14277043763� 20015� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/t/files������������������������������������������������������������������������������������������������������������������������������������������������٢gK���1qCPX!jZ���� �<1ը+5єx?V"܈ �ymW8B#T#m:k1vEյߥE�p�������7y&Zm �%MZT ̋Bhƣ(7 �D#߰,.Ny|*.𮚐>Q ������ 4\iߏ? 4waaY ib g-SmW{0 Ggeq;4Y?Ao-UL݁^I}>nvn_ll| v)rQ>C4n>7δ#p\M-E DP &q%#"f(phs]YxlFT,#uUzOUDDبN9QK6t xWWq\]xW\xn( 8)^{hq,QG"wƈ~B73o jӅMYP[bS>l^&AEq\TЁ1M!0M*IZٷdXXhSUC~rŇSPbzvRY> j6&d3],ae_,HV?-<,z$5͵Ph|kV|ko̖x$DcW -2Z1J ZZ ɸr!tp7SLb@7k-8Q;IF�)iBwfW<L i)�4Y3[k=aҽؚ[ VDPLO]IC,2wdM"%b-k]YkW_uGʃ|1LOJй XQ $.@W_VFx@w_o7:t*ݹbB=/%NZ.讀]И" fʛUϖݞjj=vz?e'ޟ:Zҹ\]:S\w=>{Kg\`墡8?Wv'V]�ië?39 պ9M}G(/Ә2q U4HI:[7yf@eň*FRl3B |6@X|e%":px/{p 5?jP9sǀͭMhK <)޾a_ %QލАMȭn) CXuYxKD,f]#׀IpL/[o[hb.b׉GKTTf6l1@$b,f(pŬ0IsED3(uc&m.E];&5m nǗ$(滐EiD֏WeY�.pPG̍_muJ6{*J zڥ2wkJsN&T]6Q l#L=-ҿ|)\!"bC"펙Qr,0C4J W~dxBlE蜰@Hˆ6ү}$phVU j)qY!ӎ$[ٗ(kΤ"<b6#u܄\3 44Ioެ@U$G?;k#2-*G Nt}^=<?B"^_x fk^'< į KX0E4҃י&:4~PjßHnNV Y]]8Y`pI-Z;fp53*9%ю8\^ydIը5 fY ,nyrcυ_S$Jxʐy-tv-`9ih?( kb:ވY882aEzm36hbls"/@>Ri-$G`kU��������������������������������������������������Stream.pm�������������������������������������������������������������������������������������������100644��023420��023420�� 11370�14277043763� 17466� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/Cipher�����������������������������������������������������������������������������������������������������������������������������������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.906'; # 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; } load $pkg; 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.906 =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 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Composite.pm����������������������������������������������������������������������������������������100644��023420��023420�� 7034�14277043763� 17475� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/Key��������������������������������������������������������������������������������������������������������������������������������������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.906'; # 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.906 =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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ChallengeResponse.pm��������������������������������������������������������������������������������100644��023420��023420�� 6252�14277043763� 21135� 0����������������������������������������������������������������������������������������������������ustar�00chaz����������������������������chaz����������������������������000000��000000��File-KDBX-0.906/lib/File/KDBX/Key��������������������������������������������������������������������������������������������������������������������������������������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.906'; # 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.906 =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 owner 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 one 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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������