[ViewVC] Annotation of: cvs/pbcdedit/pbcdedit

#!/usr/bin/perl

#
# PBCDEDIT - Copyright 2019 Marc A. Lehmann <pbcbedit@schmorp.de>
#
# SPDX-License-Identifier: GPL-3.0-or-later
#
# 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 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <https://www.gnu.org/licenses/>.
#

use 5.016; # numerous features need 5.14, __SUB__ needs 5.16

our $VERSION = '1.5';
our $JSON_VERSION = 3; # the version of the json objects generated by this program

our $CHANGELOG = <<EOF;

1.5  Mon Nov 25 15:54:34 CET 2019
        - add "del" edit instruction.
        - work around lsblk bug sometimes giving "dos" pttype for gpt partitions.
        - bootmenupolicy in synopsis must be set to 0 to get the text menu.
        - minor doc fxes.
        - disable use of perldoc for help, doesn't work well.

1.4  Thu Aug 22 10:48:22 CEST 2019
        - new "create" subcommand.
        - "create" and "edit" try to save and restore ownership/permissions
          of bcd hives when writing the new file.
        - editorial fixes to the documentation.
        - add mininmal hive creation example.

1.3  Sat Aug 17 07:04:15 CEST 2019
        - output of pbcdedit elements --json has changed, as it didn't
          take the reorganisation by classes fully into account.
        - json schema bumped to 3.
        - new "bcd-device" and "bcd-legacy-device" subcommands.
        - implement --json option for lsblk.

1.2  Fri Aug 16 00:20:41 CEST 2019
        - bcd element names now depend on the bcd object type they are in,
          also affects "elements" output.
        - json schema bumped to 2.
        - new version command.
        - numerous minor bugfixes.

EOF

=head1 NAME

   pbcdedit - portable boot configuration data (BCD) store editor

=head1 SYNOPSIS

   pbcdedit help                # output manual page
   pbcdedit version             # output version and changelog

   pbcdedit export path/to/BCD  # output BCD hive as JSON
   pbcdedit import path/to/BCD  # convert standard input to BCD hive
   pbcdedit edit path/to/BCD edit-instructions...

   pbcdedit objects             # list all supported object aliases and types
   pbcdedit elements            # list all supported bcd element aliases

   # Example: enable text-based boot menu.
   pbcdedit edit /my/BCD set '{default}' bootmenupolicy 0

   # Example change system device to first partition containing winload.
   pbcdedit edit /my/BCD \
      set '{default}' device 'locate=<null>,element,path' \
      set '{default}' osdevice 'locate=<null>,element,path'


=head1 DESCRIPTION

This program allows you to create, read and modify Boot Configuration Data
(BCD) stores used by Windows Vista and newer versions of Windows.

At this point, it is in relatively early stages of development and has
received little to no real-world testing.

Compared to other BCD editing programs it offers the following unique
features:

=over

=item Can create BCD hives from scratch

Practically all other BCD editing programs force you to copy existing BCD
stores, which might or might not be copyrighted by Microsoft.

=item Does not rely on Windows

As the "portable" in the name implies, this program does not rely on
C<bcdedit> or other windows programs or libraries, it works on any system
that supports at least perl version 5.16.

=item Decodes and encodes BCD device elements

PBCDEDIT can concisely decode and encode BCD device element contents. This
is pretty unique, and offers a lot of potential that can't be realised
with C<bcdedit> or any programs relying on it.

=item Minimal files

BCD files written by PBCDEDIT are always "minimal", that is, they don't
contain unused data areas and therefore don't contain old and potentially
sensitive data.

=back

The target audience for this program is professionals and tinkerers who
are ready to invest time into learning how it works. It is not an easy
program to use and requires patience and a good understanding of BCD
stores.


=head1 SUBCOMMANDS

PBCDEDIT expects a subcommand as first argument that tells it what to
do. The following subcommands exist:

=over

=item C<help>

Displays the whole manual page (this document).

=item C<version>

This outputs the PBCDEDIT version, the JSON schema version it uses and the
full log of changes.

=item C<export> F<path>

Reads a BCD data store and writes a JSON representation of it to standard
output.

The format of the data is explained later in this document.

Example: read a BCD store, modify it with an external program, write it
again.

   pbcdedit export BCD | modify-json-somehow | pbcdedit import BCD

=item C<import> F<path>

The reverse of C<export>: Reads a JSON representation of a BCD data store
from standard input, and creates or replaces the given BCD data store.

=item C<edit> F<path> I<instructions...>

Load a BCD data store, apply some instructions to it, and save it again.

See the section L<EDITING BCD STORES>, below, for more info.

=item C<parse> F<path> I<instructions...>

Same as C<edit>, above, except it doesn't save the data store again. Can
be useful to extract some data from it.

=item C<create> F<path> I<instructions...>

Same as C<edit>, above, except it creates a new data store from scratch if
needed. An existing store will be emptied completely.

=item C<lsblk> [C<--json>]

On a GNU/Linux system, you can get a list of partition device descriptors
using this command - the external C<lsblk> command is required, as well as
a mounted C</sys> file system.

The output will be a list of all partitions in the system and C<partition>
descriptors for GPT and both C<legacypartition> and C<partition>
descriptors for MBR partitions.

With C<--json> it will print similar information as C<lsblk --json>, but
with extra C<bcd_device> and C<bcd_legacy_device> attributes.

=item C<bcd-device> F<path>

Tries to find the BCD device element for the given device, which currently
must be a a partition of some kind. Prints the C<partition=> descriptor as
a result, or nothing. Exit status will be true on success, and false on
failure.

Like C<lsblk>, above, this likely only works on GNU/Linux systems.

Example: print the partition descriptor of tghe partition with label DATA.

   $ pbcdedit bcd-device /dev/disk/by-label/DATA
   partition=<null>,harddisk,mbr,47cbc08a,213579202560

=item C<bcd-legacy-device> F<path>

Like above, but uses a C<legacypartition> descriptor instead.

=item C<objects> [C<--json>]

Outputs two tables: a table listing all type aliases with their hex BCD
element ID, and all object name aliases with their GUID and default type
(if any).

With C<--json> it prints similar information as a JSON object, for easier parsing.

=item C<elements> [C<--json>]

Outputs a table of known element aliases with their hex ID and the format
type.

With C<--json> it prints similar information as a JSON object, for easier parsing.

=item C<export-regf> F<path>

This has nothing to do with BCD stores, but simply exposes PCBEDIT's
internal registry hive reader - it takes a registry hive file as argument
and outputs a JSON representation of it to standard output.

Hive versions 1.2 till 1.6 are supported.

=item C<import-regf> F<path>

The reverse of C<export-regf>: reads a JSON representation of a registry
hive from standard input and creates or replaces the registry hive file
given as argument.

The written hive will always be in a slightly modified version 1.3
format. It's not the format windows would generate, but it should be
understood by any conformant hive reader.

Note that the representation chosen by PBCDEDIT currently throws away
classname data (often used for feeble attempts at hiding stuff by
Microsoft) and security descriptors, so if you write anything other than
a BCD hive you will most likely destroy it.

=back


=head1 BCD STORE REPRESENTATION FORMAT

A BCD data store is represented as a JSON object with one special key,
C<meta>, and one key per BCD object. That is, each BCD object becomes
one key-value pair in the object, and an additional key called C<meta>
contains meta information.

Here is an abridged example of a real BCD store:

   {
      "meta" : {
         "version" : 1
      },
      "{7ae02178-821d-11e7-8813-1c872c5f5ab0}" : {
         "type" : "application::osloader",
         "description" : "Windows 10",
         "device" : "partition=<null>,harddisk,gpt,9742e468-9206-48a0-b4e4-c4e9745a356a,3ce6aceb-e90c-4fd2-9fba-47cab15f6faf",
         "osdevice" : "partition=<null>,harddisk,gpt,9742e468-9206-48a0-b4e4-c4e9745a356a,3ce6aceb-e90c-4fd2-9fba-47cab15f6faf",
         "path" : "\\Windows\\system32\\winload.exe",
         "systemroot" : "\\Windows"
      },
      "{bootloadersettings}" : {
         "inherit" : "{globalsettings} {hypervisorsettings}"
      },
      "{bootmgr}" : {
         "description" : "Windows Boot Manager",
         "device" : "partition=<null>,harddisk,mbr,ff3ba63b,1048576",
         "displayorder" : "{7ae02178-821d-11e7-8813-1c872c5f5ab0}",
         "inherit" : "{globalsettings}",
         "displaybootmenu" : 0,
         "timeout" : 30
      },
      "{globalsettings}" : {
         "inherit" : "{dbgsettings} {emssettings} {badmemory}"
      },
      "{hypervisorsettings}" : {
         "hypervisorbaudrate" : 115200,
         "hypervisordebugport" : 1,
         "hypervisordebugtype" : 0
      },
      # ...
   }

=head2 Minimal BCD to boot windows

Experimentally I found the following BCD is the minimum required to
successfully boot any post-XP version of Windows (assuming suitable
C<device> and C<osdevice> values, of course, and assuming a BIOS boot -
for UEFI, you should use F<winload.efi> instead of F<winload.exe>):

   {
      "{bootmgr}" : {
         "default" : "{45b547a7-8ca6-4417-9eb0-a257b61f35b4}"
      },
      
      "{45b547a7-8ca6-4417-9eb0-a257b61f35b1}" : {
         "type"        : "application::osloader",
         "description" : "Windows Boot",
         "device"      : "legacypartition=<null>,harddisk,mbr,47cbc08a,1",
         "osdevice"    : "legacypartition=<null>,harddisk,mbr,47cbc08a,1",
         "path"        : "\\Windows\\system32\\winload.exe",
         "systemroot"  : "\\Windows"
      },
   }

Note that minimal doesn't mean recommended - Windows itself will add stuff
to this during or after boot, and you might or might not run into issues
when installing updates as it might not be able to find the F<bootmgr>.

This is how you would create a minimal hive with PBCDEDIT from within
GNU/Linux, assuming F</dev/sdc3> is the windows partition, using
a random GUID for the osloader and using C<partition> instead of
C<legacypartition>:

   osldr="{$(uuidgen)}"
   part=$(pbcdedit bcd-device /dev/sdc3)
   pbcdedit create minimal.bcd \
      set '{bootmgr}' default "$osldr" \
      set "$osldr" type         application::osloader \
      set "$osldr" description 'Windows Boot' \
      set "$osldr" device      "$part" \
      set "$osldr" osdevice    "$part" \
      set "$osldr" path        '\Windows\system32\winload.exe' \
      set "$osldr" systemroot  '\Windows'

=head2 The C<meta> key

The C<meta> key is not stored in the BCD data store but is used only
by PBCDEDIT. It is always generated when exporting, and importing will
be refused when it exists and the version stored inside doesn't match
the JSON schema version of PBCDEDIT. This ensures that different and
incompatible versions of PBCDEDIT will not read and misinterpret each
others data.

=head2 The object keys

Every other key is a BCD object. There is usually a BCD object for the
boot manager, one for every boot option and a few others that store common
settings inherited by these.

Each BCD object is represented by a GUID wrapped in curly braces. These
are usually random GUIDs used only to distinguish BCD objects from each
other. When adding a new boot option, you can simply generate a new GUID.

Some of these GUIDs are fixed well known GUIDs which PBCDEDIT will decode
into human-readable strings such as C<{globalsettings}>, which is the same
as C<{7ea2e1ac-2e61-4728-aaa3-896d9d0a9f0e}>.

Each BCD object has an associated type. For example,
C<application::osloader> for objects loading Windows via F<winload.exe>,
C<application::bootsector> for real mode applications and so on.

The type of a object is stored in the pseudo BCD element C<type> (see next
section).

Some well-known objects have a default type. If an object type matches
its default type, then the C<type> element will be omitted. Similarly, if
the C<type> element is missing and the BCD object has a default type, the
default type will be used when writing a BCD store.

Running F<pbcdedit objects> will give you a list of object types,
well-known object aliases and their default types.

If different string keys in a JSON BCD store map to the same BCD object
then a random one will "win" and the others will be discarded. To avoid
this, you should always use the "canonical" name of a BCD object, which is
the human-readable form (if it exists).

=head2 The object values - BCD elements

The value of each BCD object entry consists of key-value pairs called BCD
elements.

BCD elements are identified by a 32 bit number, but to make things
simpler PBCDEDIT will replace these with well-known strings such as
C<description>, C<device> or C<path>.

When PBCDEDIT does not know the BCD element, it will use
C<custom:HHHHHHHH>, where C<HHHHHHHH> is the 8-digit hex number of the
BCD element. For example, C<device> would be C<custom::11000001>. You can
get a list of all BCD elements known to PBCDEDIT by running F<pbcdedit
elements>.

What was said about duplicate keys mapping to the same object is true for
elements as well, so, again, you should always use the canonical name,
which is the human readable alias, if known.

=head3 BCD element types

Each BCD element has a type such as I<string> or I<boolean>. This type
determines how the value is interpreted, and most of them are pretty easy
to explain:

=over

=item string

This is simply a unicode string. For example, the C<description> and
C<systemroot> elements both are of this type, one storing a human-readable
name for this boot option, the other a file path to the windows root
directory:

   "description" : "Windows 10",
   "systemroot" : "\\Windows",

=item boolean

Almost as simple are booleans, which represent I<true>/I<false>,
I<on>/I<off> and similar values. In the JSON form, true is represented
by the number C<1>, and false is represented by the number C<0>. Other
values will be accepted, but PBCDEDIT doesn't guarantee how these are
interpreted.

For example, C<displaybootmenu> is a boolean that decides whether to
enable the C<F8> boot menu. In the example BCD store above, this is
disabled:

   "displaybootmenu" : 0,

=item integer

Again, very simple, this is a 64 bit integer. It can be either specified
as a decimal number, as a hex number (by prefixing it with C<0x>) or as a
binary number (prefix C<0b>).

For example, the boot C<timeout> is an integer, specifying the automatic
boot delay in seconds:

   "timeout" : 30,

=item integer list

This is a list of 64 bit integers separated by whitespace. It is not used
much, so here is a somewhat artificial and untested example of using
C<customactions> to specify a certain custom, eh, action to be executed
when pressing C<F10> at boot:

   "customactions" : "0x1000044000001 0x54000001",

=item guid

This represents a single GUID value wrapped in curly braces. It is used a
lot to refer from one BCD object to other one.

For example, The C<{bootmgr}> object might refer to a resume boot option
using C<default>:

   "default" : "{7ae02178-821d-11e7-8813-1c872c5f5ab0}",

Human readable aliases are used and allowed.

=item guid list

Similar to the GUID type, this represents a list of such GUIDs, separated
by whitespace from each other.

For example, many BCD objects can I<inherit> elements from other BCD
objects by specifying the GUIDs of those other objects in a GUID list
called surprisingly called C<inherit>:

   "inherit" : "{dbgsettings} {emssettings} {badmemory}",

This example also shows how human readable aliases can be used.

=item device

This type is why I write I<most> are easy to explain earlier: This type
is the pinnacle of Microsoft-typical hacks layered on top of other
hacks. Understanding this type took more time than writing all the rest of
PBCDEDIT, and because it is so complex, this type has its own subsection
below.

=back

=head3 The BCD "device" element type

Device elements specify, well, devices. They are used for such diverse
purposes such as finding a TFTP network boot image, serial ports or VMBUS
devices, but most commonly they are used to specify the disk (harddisk,
cdrom, ramdisk, vhd...) to boot from.

The device element is kind of a mini-language in its own which is much
more versatile then the limited windows interface to it - BCDEDIT -
reveals.

While some information can be found on the BCD store and the windows
registry, there is pretty much no public information about the device
element, so almost everything known about it had to be researched first
in the process of writing this script, and consequently, support for BCD
device elements is partial only.

On the other hand, the expressive power of PBCDEDIT in specifying devices
is much greater than BCDEDIT and therefore more can be done with it. The
downside is that BCD device elements are much more complicated than what
you might think from reading the BCDEDIT documentation.

In other words, simple things are complicated, and complicated things are
possible.

Anyway, the general syntax of device elements is an optional GUID,
followed by a device type, optionally followed by hexadecimal flags in
angle brackets, optionally followed by C<=> and a comma-separated list of
arguments, some of which can be (and often are) in turn devices again.

   [{GUID}]type[<flags>][=arg,arg...]

Here are some examples:

   boot
   {b097d29f-bc00-11e9-8a9a-525400123456}block=file,<boot>,\EFI
   locate=<null>,element,systemroot
   partition=<null>,harddisk,mbr,47cbc08a,1048576
   partition=<null>,harddisk,gpt,9742e468-9206-48a0-b4e4-c4e9745a356a,76d39e5f-ad1b-407e-9c05-c81eb83b57dd
   block<1>=ramdisk,<partition=<null>,harddisk,mbr,47cbc08a,68720525312>,0,0,0,\Recovery\b097d29e-bc00-11e9-8a9a-525400123456\Winre.wim
   block=file,<partition=<null>,harddisk,gpt,9742e468-9206-48a0-b4e4-c4e9745a356a,ee3a393a-f0de-4057-9946-88584245ed48>,\
   binary=050000000000000048000000000000000000000000000000000000000000000000000000000000000

I hope you are suitably impressed. I was, too, when I realized decoding
these binary blobs is not as easy as I had assumed.

The optional prefixed GUID seems to refer to a device BCD object, which
can be used to specify more device-specific BCD elements (for example
C<ramdisksdidevice> and C<ramdisksdpath>).

The flags after the type are omitted when they are C<0>. The only known
flag is C<1>, which seems to indicate that the parent device is invalid. I
don't claim to fully understand it, but it seems to indicate that the
boot manager has to search the device itself. Why the device is specified
in the first place escapes me, but a lot of this device stuff seems to be
badly hacked together...

The types understood and used by PBCDEDIT are as follows (keep in mind
that not of all the following is necessarily supported in PBCDEDIT):

=over

=item C<binary=>I<hex...>

This type isn't actually a real BCD element type, but a fallback for those
cases where PBCDEDIT can't perfectly decode a device element (except for
the leading GUID, which it can always decode). In such cases, it will
convert the device into this type with a hexdump of the element data.

=item C<null>

This is another special type - sometimes, a device is all zero-filled,
which is not valid. This can mark the absence of a device or something
PBCDEDIT does not understand, so it decodes it into this special "all
zero" type called C<null>.

It's most commonly found in devices that can use an optional parent
device, when no parent device is used.

=item C<boot>

Another type without parameters, this refers to the device that was booted
from (nowadays typically the EFI system partition).

=item C<vmbus=>I<interfacetype>,I<interfaceinstance>

This specifies a VMBUS device with the given interface type and interface
instance, both of which are "naked" (no curly braces) GUIDs.

Made-up example (couldn't find a single example on the web):

   vmbus=c376c1c3-d276-48d2-90a9-c04748072c60,12345678-a234-b234-c234-d2345678abcd

=item C<partition=><I<parent>>,I<devicetype>,I<partitiontype>,I<diskid>,I<partitionid>

This designates a specific partition on a block device. I<parent> is an
optional parent device on which to search on, and is often C<null>. Note
that the angle brackets around I<parent> are part of the syntax.

I<devicetypes> is one of C<harddisk>, C<floppy>, C<cdrom>, C<ramdisk>,
C<file> or C<vhd>, where the first three should be self-explaining,
C<file> is usually used to locate a file to be used as a disk image,
and C<vhd> is used to treat files as virtual harddisks, i.e. F<vhd> and
F<vhdx> files.

The I<partitiontype> is either C<mbr>, C<gpt> or C<raw>, the latter being
used for devices without partitions, such as cdroms, where the "partition"
is usually the whole device.

The I<diskid> identifies the disk or device using a unique signature, and
the same is true for the I<partitionid>. How these are interpreted depends
on the I<partitiontype>:

=over

=item C<mbr>

The C<diskid> is the 32 bit disk signature stored at offset 0x1b8 in the
MBR, interpreted as a 32 bit unsigned little endian integer and written as
hex number. That is, the bytes C<01 02 03 04> would become C<04030201>.

Diskpart (using the C<DETAIL> command) and the C<lsblk> command typically
found on GNU/Linux systems (using e.g. C<lsblk -o NAME,PARTUUID>) can
display the I<diskid>.

The I<partitionid> is the byte offset(!) of the partition counting from
the beginning of the MBR.

Example, use the partition on the harddisk with I<diskid> C<47cbc08a>
starting at sector C<2048> (= 1048576 / 512).

   partition=<null>,harddisk,mbr,47cbc08a,1048576

=item C<gpt>

The I<diskid> is the disk GUID/disk identifier GUID from the partition
table (as displayed e.g. by F<gdisk>), and the I<partitionid> is the
partition unique GUID (displayed using e.g. the F<gdisk> F<i> command).

Example: use the partition C<76d39e5f-ad1b-407e-9c05-c81eb83b57dd> on GPT
disk C<9742e468-9206-48a0-b4e4-c4e9745a356a>.

   partition=<null>,harddisk,gpt,9742e468-9206-48a0-b4e4-c4e9745a356a,76d39e5f-ad1b-407e-9c05-c81eb83b57dd

=item C<raw>

Instead of I<diskid> and I<partitionid>, this type only accepts a decimal
disk number and signifies the whole disk. BCDEDIT cannot display the
resulting device, and I am doubtful whether it has a useful effect.

=back

=item C<legacypartition=><I<parent>>,I<devicetype>,I<partitiontype>,I<diskid>,I<partitionid>

This is exactly the same as the C<partition> type, except for a tiny
detail: instead of using the partition start offset, this type uses the
partition number for MBR disks. Behaviour other partition types should be
the same.

The partition number starts at C<1> and skips unused partition, so if
there are two primary partitions and another partition inside the extended
partition, the primary partitions are number C<1> and C<2> and the
partition inside the extended partition is number C<3>, regardless of any
gaps.

=item C<locate=><I<parent>>,I<locatetype>,I<locatearg>

This device description will make the bootloader search for a partition
with a given path.

The I<parent> device is the device to search on (angle brackets are
still part of the syntax!) If it is C<null>, then C<locate> will
search all disks it can find.

I<locatetype> is either C<element> or C<path>, and merely distinguishes
between two different ways to specify the path to search for: C<element>
uses an element ID (either as hex or as name) as I<locatearg> and C<path>
uses a relative path as I<locatearg>.

Example: find any partition which has the F<magicfile.xxx> path in the
root.

   locate=<null>,path,\magicfile.xxx

Example: find any partition which has the path specified in the
C<systemroot> element (typically F<\Windows>).

   locate=<null>,element,systemroot

=item C<block=>I<devicetype>,I<args...>

Last not least, the most complex type, C<block>, which... specifies block
devices (which could be inside a F<vhdx> file for example).

I<devicetypes> is one of C<harddisk>, C<floppy>, C<cdrom>, C<ramdisk>,
C<file> or C<vhd> - the same as for C<partition=>.

The remaining arguments change depending on the I<devicetype>:

=over

=item C<block=file>,<I<parent>>,I<path>

Interprets the I<parent> device (typically a partition) as a
filesystem and specifies a file path inside.

=item C<block=vhd>,<I<parent>>

Pretty much just changes the interpretation of I<parent>, which is
usually a disk image (C<block=file,...)>) to be a F<vhd> or F<vhdx> file.

=item C<block=ramdisk>,<I<parent>>,I<base>,I<size>,I<offset>,I<path>

Interprets the I<parent> device as RAM disk, using the (decimal)
base address, byte size and byte offset inside a file specified by
I<path>. The numbers are usually all C<0> because they can be extracted
from the RAM disk image or other parameters.

This is most commonly used to boot C<wim> images.

=item C<block=floppy>,I<drivenum>

Refers to a removable drive identified by a number. BCDEDIT cannot display
the resulting device, and it is not clear what effect it will have.

=item C<block=cdrom>,I<drivenum>

Pretty much the same as C<floppy> but for CD-ROMs.

=item anything else

Probably not yet implemented. Tell me of your needs...

=back

=back

=head4 Examples

This concludes the syntax overview for device elements, but probably
leaves many questions open. I can't help with most of them, as I also have
many questions, but I can walk you through some actual examples using more
complex aspects.

=over

=item C<< locate=<block=vhd,<block=file,<locate=<null>,path,\disk.vhdx>,\disk.vhdx>>,element,path >>

Just like with C declarations, you best treat device descriptors as
instructions to find your device and work your way from the inside out:

   locate=<null>,path,\disk.vhdx

First, the innermost device descriptor searches all partitions on the
system for a file called F<\disk.vhdx>:

   block=file,<see above>,\disk.vhdx

Next, this takes the device locate has found and finds a file called
F<\disk.vhdx> on it. This is the same file locate was using, but that is
only because we find the device using the same path as finding the disk
image, so this is purely incidental, although quite common.

Next, this file will be opened as a virtual disk:

   block=vhd,<see above>

And finally, inside this disk, another C<locate> will look for a partition
with a path as specified in the C<path> element, which most likely will be
F<\Windows\system32\winload.exe>:

   locate=<see above>,element,path

As a result, this will boot the first Windows it finds on the first
F<disk.vhdx> disk image it can find anywhere.

=item C<< locate=<block=vhd,<block=file,<partition=<null>,harddisk,mbr,47cbc08a,242643632128>,\win10.vhdx>>,element,path >>

Pretty much the same as the previous case, but with a bit of
variance. First, look for a specific partition on an MBR-partitioned disk:

   partition=<null>,harddisk,mbr,47cbc08a,242643632128

Then open the file F<\win10.vhdx> on that partition:

   block=file,<see above>,\win10.vhdx

Then, again, the file is opened as a virtual disk image:

   block=vhd,<see above>

And again the windows loader (or whatever is in C<path>) will be searched:

   locate=<see above>,element,path

=item C<< {b097d2b2-bc00-11e9-8a9a-525400123456}block<1>=ramdisk,<partition=<null>,harddisk,mbr,47cbc08a,242643632128>,0,0,0,\boot.wim >>

This is quite different. First, it starts with a GUID. This GUID belongs
to a BCD object of type C<device>, which has additional parameters:

   "{b097d2b2-bc00-11e9-8a9a-525400123456}" : {
      "type"             : "device",
      "description"      : "sdi file for ramdisk",
      "ramdisksdidevice" : "partition=<null>,harddisk,mbr,47cbc08a,1048576",
      "ramdisksdipath"   : "\boot.sdi"
   },

I will not go into many details, but this specifies a (presumably empty)
template ramdisk image (F<\boot.sdi>) that is used to initialize the
ramdisk. The F<\boot.wim> file is then extracted into it. As you can also
see, this F<.sdi> file resides on a different C<partition>.

Continuing, as always, from the inside out, first this device descriptor
finds a specific partition:

   partition=<null>,harddisk,mbr,47cbc08a,242643632128

And then specifies a C<ramdisk> image on this partition:

   block<1>=ramdisk,<see above>,0,0,0,\boot.wim

I don't know what the purpose of the C<< <1> >> flag value is, but it
seems to be always there on this kind of entry.

If you have some good examples to add here, feel free to mail me.

=back


=head1 EDITING BCD STORES

The C<edit> and C<parse> subcommands allow you to read a BCD data store
and modify it or extract data from it. This is done by executing a series
of "editing instructions" which are explained here.

=over

=item C<get> I<object> I<element>

Reads the BCD element I<element> from the BCD object I<object> and writes
it to standard output, followed by a newline. The I<object> can be a GUID
or a human-readable alias, or the special string C<{default}>, which will
refer to the default BCD object.

Example: find description of the default BCD object.

   pbcdedit parse BCD get "{default}" description

=item C<set> I<object> I<element> I<value>

Similar to C<get>, but sets the element to the given I<value> instead.

Example: change the bootmgr default too
C<{b097d2ad-bc00-11e9-8a9a-525400123456}>:

   pbcdedit edit BCD set "{bootmgr}" default "{b097d2ad-bc00-11e9-8a9a-525400123456}"

=item C<del> I<object> I<element>

Similar to C<get>, but removed the BCD element from the specified BCD object.

=item C<eval> I<perlcode>

This takes the next argument, interprets it as Perl code and
evaluates it. This allows you to do more complicated modifications or
extractions.

The following variables are predefined for your use:

=over

=item C<$PATH>

The path to the BCD data store, as given to C<edit> or C<parse>.

=item C<$BCD>

The decoded BCD data store.

=item C<$DEFAULT>

The default BCD object name.

=back

The example given for C<get>, above, could be expressed like this with
C<eval>:

   pbcdedit edit BCD eval 'say $BCD->{$DEFAULT}{description}'

The example given for C<set> could be expressed like this:

   pbcdedit edit BCD eval '$BCD->{"{bootmgr}"}{default} = "{b097d2ad-bc00-11e9-8a9a-525400123456}"'

=item C<do> I<path>

Similar to C<eval>, above, but instead of using the argument as perl code,
it loads the perl code from the given file and executes it. This makes it
easier to write more complicated or larger programs.

=back


=head1 SEE ALSO

For ideas on what you can do with BCD stores in
general, and some introductory material, try
L<http://www.mistyprojects.co.uk/documents/BCDEdit/index.html>.

For good reference on which BCD objects and
elements exist, see Geoff Chappell's pages at
L<http://www.geoffchappell.com/notes/windows/boot/bcd/index.htm>.

=head1 AUTHOR

Written by Marc A. Lehmann L<pbcdedit@schmorp.de>.

=head1 REPORTING BUGS

Bugs can be reported directly the author at L<pcbedit@schmorp.de>.

=head1 BUGS AND SHORTCOMINGS

This should be a module. Of a series of modules, even.

Registry code should preserve classname and security descriptor data, and
whatever else is necessary to read and write any registry hive file.

I am also not happy with device descriptors being strings rather than a
data structure, but strings are probably better for command line usage. In
any case, device descriptors could be converted by simply "splitting" at
"=" and "," into an array reference, recursively.

=head1 HOMEPAGE

Original versions of this program can be found at
L<http://software.schmorp.de/pkg/pbcdedit>.

=head1 COPYRIGHT

Copyright 2019 Marc A. Lehmann, licensed under GNU GPL version 3 or later,
see L<https://gnu.org/licenses/gpl.html>. This is free software: you are
free to change and redistribute it. There is NO WARRANTY, to the extent
permitted by law.

=cut

# common sense is optional, but recommended
BEGIN { eval { require "common/sense.pm"; } && common::sense->import }

no warnings 'portable'; # avoid 32 bit integer warnings

use Encode ();
use List::Util ();
use IO::Handle ();
use Time::HiRes ();

eval { unpack "Q", pack "Q", 1 }
   or die "perl with 64 bit integer supported required.\n";

our $JSON = eval { require JSON::XS; JSON::XS:: }
         // eval { require JSON::PP; JSON::PP:: }
         // die "either JSON::XS or JSON::PP must be installed\n";

our $json_coder = $JSON->new->utf8->pretty->canonical->relaxed;

# hack used for debugging
sub xxd($$) {
   open my $xxd, "| xxd | sed -e 's/^/\Q$_[0]\E: /'";
   syswrite $xxd, $_[1];
}

# get some meta info on a file (uid, gid, perms)
sub stat_get($) {
   [(stat shift)[4, 5, 2]]
}

# set stat info on a file
sub stat_set($$) {
   my ($fh_or_path, $stat) = @_;

   return unless $stat;
   chown $stat->[0], $stat->[1], $fh_or_path;
   chmod +($stat->[2] & 07777), $fh_or_path;
}

sub file_load($) {
   my ($path) = @_;

   open my $fh, "<:raw", $path
      or die "$path: $!\n";
   my $size = -s $fh;
   $size = read $fh, my $buf, $size
      or die "$path: short read\n";

   $buf
}

sub file_save($$;$) {
   my ($path, $data, $stat) = @_;

   open my $fh, ">:raw", "$path~"
      or die "$path~: $!\n";
   print $fh $data
      or die "$path~: short write\n";
   stat_set $fh, $stat;
   $fh->sync;
   close $fh;

   rename "$path~", $path;
}

# sources and resources used for writing pbcdedit
#
# registry:
# https://github.com/msuhanov/regf/blob/master/Windows%20registry%20file%20format%20specification.md
# http://amnesia.gtisc.gatech.edu/~moyix/suzibandit.ltd.uk/MSc/
# bcd:
# http://www.geoffchappell.com/notes/windows/boot/bcd/index.htm
# https://docs.microsoft.com/en-us/previous-versions/windows/hardware/design/dn653287(v=vs.85)
# bcd devices:
# reactos' boot/environ/include/bl.h
# windows .mof files

#############################################################################
# registry stuff

# we use a hardcoded securitya descriptor - full access for everyone
my $sid  = pack "H*", "010100000000000100000000"; # S-1-1-0 everyone
my $ace  = pack "C C S< L< a*", 0, 2, 8 + (length $sid), 0x000f003f, $sid; # type flags size mask sid
my $sacl = "";
my $dacl = pack "C x S< S< x2 a*", 2, 8 + (length $ace), 1, $ace; # rev size count ace*
my $sd   = pack "C x S< L< L< L< L< a* a* a* a*",
              # rev flags(SE_DACL_PRESENT SE_SELF_RELATIVE) owner group sacl dacl
              1, 0x8004,
              20 + (length $sacl) + (length $dacl),
              20 + (length $sacl) + (length $dacl) + (length $sid),
              0, 20,
              $sacl, $dacl, $sid, $sid;
my $sk = pack "a2 x2 x4 x4 x4 L< a*", sk => (length $sd), $sd;

sub NO_OFS() { 0xffffffff } # file pointer "NULL" value

sub KEY_HIVE_ENTRY() { 0x0004 }
sub KEY_NO_DELETE () { 0x0008 }
sub KEY_COMP_NAME () { 0x0020 }

sub VALUE_COMP_NAME() { 0x0001 }

my @regf_typename = qw(
   none sz expand_sz binary dword dword_be link multi_sz
   resource_list full_resource_descriptor resource_requirements_list
   qword qword_be
);

my %regf_dec_type = (
   sz        => sub { $_[0] =~ s/\x00\x00$//; Encode::decode "UTF-16LE", $_[0] },
   expand_sz => sub { $_[0] =~ s/\x00\x00$//; Encode::decode "UTF-16LE", $_[0] },
   link      => sub { $_[0] =~ s/\x00\x00$//; Encode::decode "UTF-16LE", $_[0] },
   multi_sz  => sub { $_[0] =~ s/(?:\x00\x00)?\x00\x00$//; [ split /\x00/, (Encode::decode "UTF-16LE", $_[0]), -1 ] },
   dword     => sub { unpack "L<", shift },
   dword_be  => sub { unpack "L>", shift },
   qword     => sub { unpack "Q<", shift },
   qword_be  => sub { unpack "Q>", shift },
);

my %regf_enc_type = (
   sz        => sub { (Encode::encode "UTF-16LE", $_[0]) . "\x00\x00" },
   expand_sz => sub { (Encode::encode "UTF-16LE", $_[0]) . "\x00\x00" },
   link      => sub { (Encode::encode "UTF-16LE", $_[0]) . "\x00\x00" },
   multi_sz  => sub { (join "", map +(Encode::encode "UTF-16LE", $_) . "\x00\x00", @{ $_[0] }) . "\x00\x00" },
   dword     => sub { pack "L<", shift },
   dword_be  => sub { pack "L>", shift },
   qword     => sub { pack "Q<", shift },
   qword_be  => sub { pack "Q>", shift },
);

# decode a registry hive
sub regf_decode($) {
   my ($hive) = @_;

   "regf" eq substr $hive, 0, 4
      or die "not a registry hive\n";

   my ($major, $minor) = unpack "\@20 L< L<", $hive;

   $major == 1
      or die "registry major version is not 1, but $major\n";

   $minor >= 2 && $minor <= 6
      or die "registry minor version is $minor, only 2 .. 6 are supported\n";

   my $bins = substr $hive, 4096;

   my $decode_key = sub {
      my ($ofs) = @_;

      my @res;

      my ($sze, $sig) = unpack "\@$ofs l< a2", $bins;

      $sze < 0
         or die "key node points to unallocated cell\n";

      $sig eq "nk"
         or die "expected key node at $ofs, got '$sig'\n";

      my ($flags, $snum, $sofs, $vnum, $vofs, $knamesze) = unpack "\@$ofs ( \@6 S< \@24 L< x4 L< x4 L< L< \@76 S< )", $bins;

      my $kname = unpack "\@$ofs x80 a$knamesze", $bins;

      # classnames, security descriptors
      #my ($cofs, $xofs, $clen) = unpack "\@$ofs ( \@44 L< L< \@72 S< )", $bins;
      #if ($cofs != NO_OFS && $clen) {
      #   #warn "cofs $cofs+$clen\n";
      #   xxd substr $bins, $cofs, 16;
      #}

      $kname = Encode::decode "UTF-16LE", $kname
         unless $flags & KEY_COMP_NAME;

      if ($vnum && $vofs != NO_OFS) {
         for ($vofs += 4; $vnum--; $vofs += 4) {
            my $kofs = unpack "\@$vofs L<", $bins;

            my ($sze, $sig) = unpack "\@$kofs l< a2", $bins;

            $sig eq "vk"
               or die "key values list contains invalid node (expected vk got '$sig')\n";

            my ($nsze, $dsze, $dofs, $type, $flags) = unpack "\@$kofs x4 x2 S< L< L< L< L<", $bins;

            my $name = substr $bins, $kofs + 24, $nsze;

            $name = Encode::decode "UTF-16LE", $name
               unless $flags & VALUE_COMP_NAME;

            my $data;
            if ($dsze & 0x80000000) {
               $data = substr $bins, $kofs + 12, $dsze & 0x7;
            } elsif ($dsze > 16344 && $minor > 3) { # big data
               my ($bsze, $bsig, $bnum, $bofs) = unpack "\@$dofs l< a2 S< L<", $bins;

               for ($bofs += 4; $bnum--; $bofs += 4) {
                  my $dofs = unpack "\@$bofs L<", $bins;
                  my $dsze = unpack "\@$dofs l<", $bins;
                  $data .= substr $bins, $dofs + 4, -$dsze - 4;
               }
               $data = substr $data, 0, $dsze; # cells might be longer than data
            } else {
               $data = substr $bins, $dofs + 4, $dsze;
            }

            $type = $regf_typename[$type] if $type < @regf_typename;

            $data = ($regf_dec_type{$type} || sub { unpack "H*", shift })
                    ->($data);

            $res[0]{$name} = [$type, $data];
         }
      }

      if ($sofs != NO_OFS) {
         my $decode_key = __SUB__;

         my $decode_subkeylist = sub {
            my ($sofs) = @_;

            my ($sze, $sig, $snum) = unpack "\@$sofs l< a2 S<", $bins;

            if ($sig eq "ri") { # index root
               for (my $lofs = $sofs + 8; $snum--; $lofs += 4) {
                  __SUB__->(unpack "\@$lofs L<", $bins);
               }
            } else {
               my $inc;

               if ($sig eq "li") { # subkey list
                  $inc = 4;
               } elsif ($sig eq "lf" or $sig eq "lh") { # subkey list with name hints or hashes
                  $inc = 8;
               } else {
                  die "expected subkey list at $sofs, found '$sig'\n";
               }

               for (my $lofs = $sofs + 8; $snum--; $lofs += $inc) {
                  my ($name, $data) = $decode_key->(unpack "\@$lofs L<", $bins);
                  $res[1]{$name} = $data;
               }
            }
         };

         $decode_subkeylist->($sofs);
      }

      ($kname, \@res);
   };

   my ($rootcell) = unpack "\@36 L<", $hive;

   my ($rname, $root) = $decode_key->($rootcell);

   [$rname, $root]
}

# return a binary windows FILETIME struct
sub filetime_now {
   my ($s, $ms) = Time::HiRes::gettimeofday;

   pack "Q<", ($s * 1_000_000 + $ms) * 10
              + 116_444_736_000_000_000 # 1970-01-01 00:00:00
}

# encode a registry hive
sub regf_encode($) {
   my ($hive) = @_;

   my %typeval = map +($regf_typename[$_] => $_), 0 .. $#regf_typename;

   # the filetime is apparently used to verify log file validity,
   # so by generating a new timestamp the log files *should* automatically
   # become invalidated and windows would "self-heal" them.
   # (update: has been verified by reverse engineering)
   # possibly the fact that the two sequence numbers match might also
   # make windows think that the hive is not dirty and ignore logs.
   # (update: has been verified by reverse engineering)

   my $now = filetime_now;

   # we only create a single hbin
   my $bins = pack "a4 L< L< x8 a8 x4", "hbin", 0, 0, $now;

   # append cell to $bind, return offset
   my $cell = sub {
      my ($cell) = @_;

      my $res = length $bins;

      $cell .= "\x00" while 4 != (7 & length $cell); # slow and ugly

      $bins .= pack "l<", -(4 + length $cell);
      $bins .= $cell;

      $res
   };

   my $sdofs = $cell->($sk); # add a dummy security descriptor
   my $sdref = 0; # refcount
   substr $bins, $sdofs +  8, 4, pack "L<", $sdofs; # flink
   substr $bins, $sdofs + 12, 4, pack "L<", $sdofs; # blink

   my $encode_key = sub {
      my ($kname, $kdata, $flags) = @_;
      my ($values, $subkeys) = @$kdata;

      if ($kname =~ /[^\x00-\xff]/) {
         $kname = Encode::encode "UTF-16LE", $kname;
      } else {
         $flags |= KEY_COMP_NAME;
      }

      # encode subkeys

      my @snames =
         map $_->[1],
         sort { $a->[0] cmp $b->[0] }
         map [(uc $_), $_],
         keys %$subkeys;

      # normally, we'd have to encode each name, but we assume one char is at most two utf-16 cp's
      my $maxsname = 4 * List::Util::max map length, @snames;

      my @sofs = map __SUB__->($_, $subkeys->{$_}, 0), @snames;

      # encode values
      my $maxvname = 4 * List::Util::max map length, keys %$values;
      my @vofs;
      my $maxdsze = 0;

      while (my ($vname, $v) = each %$values) {
         my $flags = 0;

         if ($vname =~ /[^\x00-\xff]/) {
            $vname = Encode::encode "UTF-16LE", $kname;
         } else {
            $flags |= VALUE_COMP_NAME;
         }

         my ($type, $data) = @$v;

         $data = ($regf_enc_type{$type} || sub { pack "H*", shift })->($data);

         my $dsze;
         my $dofs;

         if (length $data <= 4) {
            $dsze = 0x80000000 | length $data;
            $dofs = unpack "L<", pack "a4", $data;
         } else {
            $dsze = length $data;
            $dofs = $cell->($data);
         }

         $type = $typeval{$type} // ($type =~ /^[0-9]+\z/ ? $type : die "cannot encode type '$type'");

         push @vofs, $cell->(pack "a2 S< L< L< L< S< x2 a*",
            vk => (length $vname), $dsze, $dofs, $type, $flags, $vname);

         $maxdsze = $dsze if $maxdsze < $dsze;
      }

      # encode key

      my $slist = @sofs ? $cell->(pack "a2 S< L<*", li => (scalar @sofs), @sofs) : NO_OFS;
      my $vlist = @vofs ? $cell->(pack "L<*", @vofs)                             : NO_OFS;

      my $kdata = pack "
            a2 S< a8 x4 x4
            L< L< L< L< L< L<
            L< L< L< L< L< L<
            x4 S< S< a*
         ",
            nk => $flags, $now,
            (scalar @sofs), 0, $slist, NO_OFS, (scalar @vofs), $vlist,
            $sdofs, NO_OFS, $maxsname, 0, $maxvname, $maxdsze,
            length $kname, 0, $kname;
      ++$sdref;

      my $res = $cell->($kdata);

      substr $bins, $_ + 16, 4, pack "L<", $res
         for @sofs;

      $res
   };

   my ($rname, $root) = @$hive;

   my $rofs = $encode_key->($rname, $root, KEY_HIVE_ENTRY | KEY_NO_DELETE); # 4 = root key

   if (my $pad = -(length $bins) & 4095) {
      $pad -= 4;
      $bins .= pack "l< x$pad", $pad + 4;
   }

   substr $bins, $sdofs + 16, 4, pack "L<", $sdref; # sd refcount
   substr $bins, 8, 4, pack "L<", length $bins;

   my $base = pack "
         a4 L< L< a8 L< L< L< L<
         L< L< L<
         a64
         x396
      ",
      regf => 1974, 1974, $now, 1, 3, 0, 1,
      $rofs, length $bins, 1,
      (Encode::encode "UTF-16LE", "\\pbcdedit.reg");

   my $chksum = List::Util::reduce { $a ^ $b } unpack "L<*", $base;
   $chksum = 0xfffffffe if $chksum == 0xffffffff;
   $chksum =          1 if $chksum ==          0;

   $base .= pack "L<", $chksum;

   $base = pack "a* \@4095 x1", $base;

   $base . $bins
}

# load and parse registry from file
sub regf_load($) {
   my ($path) = @_;

   regf_decode file_load $path
}

# encode and save registry to file
sub regf_save($$;$) {
   my ($path, $hive, $stat) = @_;

   $hive = regf_encode $hive;

   file_save $path, $hive, $stat;
}

#############################################################################
# bcd stuff

# human-readable aliases for GUID object identifiers
our %bcd_objects = (
   '{0ce4991b-e6b3-4b16-b23c-5e0d9250e5d9}' => '{emssettings}',
   '{1afa9c49-16ab-4a5c-4a90-212802da9460}' => '{resumeloadersettings}',
   '{1cae1eb7-a0df-4d4d-9851-4860e34ef535}' => '{default}',
   '{313e8eed-7098-4586-a9bf-309c61f8d449}' => '{kerneldbgsettings}',
   '{4636856e-540f-4170-a130-a84776f4c654}' => '{dbgsettings}',
   '{466f5a88-0af2-4f76-9038-095b170dc21c}' => '{ntldr}',
   '{5189b25c-5558-4bf2-bca4-289b11bd29e2}' => '{badmemory}',
   '{6efb52bf-1766-41db-a6b3-0ee5eff72bd7}' => '{bootloadersettings}',
   '{7254a080-1510-4e85-ac0f-e7fb3d444736}' => '{ssetupefi}',
   '{7ea2e1ac-2e61-4728-aaa3-896d9d0a9f0e}' => '{globalsettings}',
   '{7ff607e0-4395-11db-b0de-0800200c9a66}' => '{hypervisorsettings}',
   '{9dea862c-5cdd-4e70-acc1-f32b344d4795}' => '{bootmgr}',
   '{a1943bbc-ea85-487c-97c7-c9ede908a38a}' => '{ostargettemplatepcat}',
   '{a5a30fa2-3d06-4e9f-b5f4-a01df9d1fcba}' => '{fwbootmgr}',
   '{ae5534e0-a924-466c-b836-758539a3ee3a}' => '{ramdiskoptions}',
   '{b012b84d-c47c-4ed5-b722-c0c42163e569}' => '{ostargettemplateefi}',
   '{b2721d73-1db4-4c62-bf78-c548a880142d}' => '{memdiag}',
   '{cbd971bf-b7b8-4885-951a-fa03044f5d71}' => '{setuppcat}',
   '{fa926493-6f1c-4193-a414-58f0b2456d1e}' => '{current}',
);

# default types
our %bcd_object_types = (
   '{fwbootmgr}'            => 0x10100001,
   '{bootmgr}'              => 0x10100002,
   '{memdiag}'              => 0x10200005,
   '{ntldr}'                => 0x10300006,
   '{badmemory}'            => 0x20100000,
   '{dbgsettings}'          => 0x20100000,
   '{emssettings}'          => 0x20100000,
   '{globalsettings}'       => 0x20100000,
   '{bootloadersettings}'   => 0x20200003,
   '{hypervisorsettings}'   => 0x20200003,
   '{kerneldbgsettings}'    => 0x20200003,
   '{resumeloadersettings}' => 0x20200004,
   '{ramdiskoptions}'       => 0x30000000,
);

# object types
our %bcd_types = (
   0x10100001 => 'application::fwbootmgr',
   0x10100002 => 'application::bootmgr',
   0x10200003 => 'application::osloader',
   0x10200004 => 'application::resume',
   0x10100005 => 'application::memdiag',
   0x10100006 => 'application::ntldr',
   0x10100007 => 'application::setupldr',
   0x10400008 => 'application::bootsector',
   0x10400009 => 'application::startup',
   0x1020000a => 'application::bootapp',
   0x20100000 => 'settings',
   0x20200001 => 'inherit::fwbootmgr',
   0x20200002 => 'inherit::bootmgr',
   0x20200003 => 'inherit::osloader',
   0x20200004 => 'inherit::resume',
   0x20200005 => 'inherit::memdiag',
   0x20200006 => 'inherit::ntldr',
   0x20200007 => 'inherit::setupldr',
   0x20200008 => 'inherit::bootsector',
   0x20200009 => 'inherit::startup',
   0x20300000 => 'inherit::device',
   0x30000000 => 'device',
);

our %rbcd_objects = reverse %bcd_objects;

our $RE_GUID = qr<([0-9a-f]{8})-([0-9a-f]{4})-([0-9a-f]{4})-([0-9a-f]{4})-([0-9a-f]{12})>i;

sub dec_guid($) {
   my ($p1, $p2, $p3, $p4, $p5) = unpack "VvvH4H12", shift;
   sprintf "%08x-%04x-%04x-%s-%s", $p1, $p2, $p3, $p4, $p5;
}

sub enc_guid($) {
   $_[0] =~ /^$RE_GUID\z/o
      or return;

   pack "VvvH4H12", hex $1, hex $2, hex $3, $4, $5
}

# "wguid" are guids wrapped in curly braces {...} also supporting aliases
sub dec_wguid($) {
   my $guid = "{" . (dec_guid shift) . "}";

   $bcd_objects{$guid} // $guid
}

sub enc_wguid($) {
   my ($guid) = @_;

   if (my $alias = $rbcd_objects{$guid}) {
      $guid = $alias;
   }

   $guid =~ /^\{($RE_GUID)\}\z/o
      or return;

   enc_guid $1
}

sub BCDE_CLASS             () { 0xf0000000 }
sub BCDE_CLASS_LIBRARY     () { 0x10000000 }
sub BCDE_CLASS_APPLICATION () { 0x20000000 }
sub BCDE_CLASS_DEVICE      () { 0x30000000 }
sub BCDE_CLASS_TEMPLATE    () { 0x40000000 }

sub BCDE_FORMAT              () { 0x0f000000 }
sub BCDE_FORMAT_DEVICE       () { 0x01000000 }
sub BCDE_FORMAT_STRING       () { 0x02000000 }
sub BCDE_FORMAT_GUID         () { 0x03000000 }
sub BCDE_FORMAT_GUID_LIST    () { 0x04000000 }
sub BCDE_FORMAT_INTEGER      () { 0x05000000 }
sub BCDE_FORMAT_BOOLEAN      () { 0x06000000 }
sub BCDE_FORMAT_INTEGER_LIST () { 0x07000000 }

sub enc_integer($) {
   my $value = shift;
   $value = oct $value if $value =~ /^0[bBxX]/;
   unpack "H*", pack "Q<", $value
}

sub enc_device($$);
sub dec_device($$);

our %bcde_dec = (
   BCDE_FORMAT_DEVICE      , \&dec_device,
#   # for round-trip verification
#   BCDE_FORMAT_DEVICE      , sub {
#      my $dev = dec_device $_[0];
#      $_[0] eq enc_device $dev
#         or die "bcd device decoding does not round trip for $_[0]\n";
#      $dev
#   },
   BCDE_FORMAT_STRING      , sub { shift },
   BCDE_FORMAT_GUID        , sub { dec_wguid enc_wguid shift },
   BCDE_FORMAT_GUID_LIST   , sub { join " ", map dec_wguid enc_wguid $_, @{+shift} },
   BCDE_FORMAT_INTEGER     , sub { unpack "Q", pack "a8", pack "H*", shift }, # integer might be 4 or 8 bytes - caused by ms coding bugs
   BCDE_FORMAT_BOOLEAN     , sub { shift eq "00" ? 0 : 1 },
   BCDE_FORMAT_INTEGER_LIST, sub { join " ", unpack "Q*", pack "H*", shift }, # not sure if this can be 4 bytes
);

our %bcde_enc = (
   BCDE_FORMAT_DEVICE      , sub { binary => enc_device $_[0], $_[1] },
   BCDE_FORMAT_STRING      , sub { sz => shift },
   BCDE_FORMAT_GUID        , sub { sz => "{" . (dec_guid enc_wguid shift) . "}" },
   BCDE_FORMAT_GUID_LIST   , sub { multi_sz => [map "{" . (dec_guid enc_wguid $_) . "}", split /\s+/, shift ] },
   BCDE_FORMAT_INTEGER     , sub { binary => enc_integer shift },
   BCDE_FORMAT_BOOLEAN     , sub { binary => shift ? "01" : "00" },
   BCDE_FORMAT_INTEGER_LIST, sub { binary => join "", map enc_integer $_, split /\s+/, shift },
);

# BCD Elements
our %bcde_byclass = (
   any => {
      0x11000001 => 'device',
      0x12000002 => 'path',
      0x12000004 => 'description',
      0x12000005 => 'locale',
      0x14000006 => 'inherit',
      0x15000007 => 'truncatememory',
      0x14000008 => 'recoverysequence',
      0x16000009 => 'recoveryenabled',
      0x1700000a => 'badmemorylist',
      0x1600000b => 'badmemoryaccess',
      0x1500000c => 'firstmegabytepolicy',
      0x1500000d => 'relocatephysical',
      0x1500000e => 'avoidlowmemory',
      0x1600000f => 'traditionalkseg',
      0x16000010 => 'bootdebug',
      0x15000011 => 'debugtype',
      0x15000012 => 'debugaddress',
      0x15000013 => 'debugport',
      0x15000014 => 'baudrate',
      0x15000015 => 'channel',
      0x12000016 => 'targetname',
      0x16000017 => 'noumex',
      0x15000018 => 'debugstart',
      0x12000019 => 'busparams',
      0x1500001a => 'hostip',
      0x1500001b => 'port',
      0x1600001c => 'dhcp',
      0x1200001d => 'key',
      0x1600001e => 'vm',
      0x16000020 => 'bootems',
      0x15000022 => 'emsport',
      0x15000023 => 'emsbaudrate',
      0x12000030 => 'loadoptions',
      0x16000040 => 'advancedoptions',
      0x16000041 => 'optionsedit',
      0x15000042 => 'keyringaddress',
      0x11000043 => 'bootstatdevice',
      0x12000044 => 'bootstatfilepath',
      0x16000045 => 'preservebootstat',
      0x16000046 => 'graphicsmodedisabled',
      0x15000047 => 'configaccesspolicy',
      0x16000048 => 'nointegritychecks',
      0x16000049 => 'testsigning',
      0x1200004a => 'fontpath',
      0x1500004b => 'integrityservices',
      0x1500004c => 'volumebandid',
      0x16000050 => 'extendedinput',
      0x15000051 => 'initialconsoleinput',
      0x15000052 => 'graphicsresolution',
      0x16000053 => 'restartonfailure',
      0x16000054 => 'highestmode',
      0x16000060 => 'isolatedcontext',
      0x15000065 => 'displaymessage',
      0x15000066 => 'displaymessageoverride',
      0x16000068 => 'nobootuxtext',
      0x16000069 => 'nobootuxprogress',
      0x1600006a => 'nobootuxfade',
      0x1600006b => 'bootuxreservepooldebug',
      0x1600006c => 'bootuxdisabled',
      0x1500006d => 'bootuxfadeframes',
      0x1600006e => 'bootuxdumpstats',
      0x1600006f => 'bootuxshowstats',
      0x16000071 => 'multibootsystem',
      0x16000072 => 'nokeyboard',
      0x15000073 => 'aliaswindowskey',
      0x16000074 => 'bootshutdowndisabled',
      0x15000075 => 'performancefrequency',
      0x15000076 => 'securebootrawpolicy',
      0x17000077 => 'allowedinmemorysettings',
      0x15000079 => 'bootuxtransitiontime',
      0x1600007a => 'mobilegraphics',
      0x1600007b => 'forcefipscrypto',
      0x1500007d => 'booterrorux',
      0x1600007e => 'flightsigning',
      0x1500007f => 'measuredbootlogformat',
      0x15000080 => 'displayrotation',
      0x15000081 => 'logcontrol',
      0x16000082 => 'nofirmwaresync',
      0x11000084 => 'windowssyspart',
      0x16000087 => 'numlock',
      0x26000202 => 'skipffumode',
      0x26000203 => 'forceffumode',
      0x25000510 => 'chargethreshold',
      0x26000512 => 'offmodecharging',
      0x25000aaa => 'bootflow',
      0x45000001 => 'devicetype',
      0x42000002 => 'applicationrelativepath',
      0x42000003 => 'ramdiskdevicerelativepath',
      0x46000004 => 'omitosloaderelements',
      0x47000006 => 'elementstomigrate',
      0x46000010 => 'recoveryos',
   },
   bootapp => {
      0x26000145 => 'enablebootdebugpolicy',
      0x26000146 => 'enablebootorderclean',
      0x26000147 => 'enabledeviceid',
      0x26000148 => 'enableffuloader',
      0x26000149 => 'enableiuloader',
      0x2600014a => 'enablemassstorage',
      0x2600014b => 'enablerpmbprovisioning',
      0x2600014c => 'enablesecurebootpolicy',
      0x2600014d => 'enablestartcharge',
      0x2600014e => 'enableresettpm',
   },
   bootmgr => {
      0x24000001 => 'displayorder',
      0x24000002 => 'bootsequence',
      0x23000003 => 'default',
      0x25000004 => 'timeout',
      0x26000005 => 'resume',
      0x23000006 => 'resumeobject',
      0x24000007 => 'startupsequence',
      0x24000010 => 'toolsdisplayorder',
      0x26000020 => 'displaybootmenu',
      0x26000021 => 'noerrordisplay',
      0x21000022 => 'bcddevice',
      0x22000023 => 'bcdfilepath',
      0x26000024 => 'hormenabled',
      0x26000025 => 'hiberboot',
      0x22000026 => 'passwordoverride',
      0x22000027 => 'pinpassphraseoverride',
      0x26000028 => 'processcustomactionsfirst',
      0x27000030 => 'customactions',
      0x26000031 => 'persistbootsequence',
      0x26000032 => 'skipstartupsequence',
      0x22000040 => 'fverecoveryurl',
      0x22000041 => 'fverecoverymessage',
   },
   device => {
      0x35000001 => 'ramdiskimageoffset',
      0x35000002 => 'ramdisktftpclientport',
      0x31000003 => 'ramdisksdidevice',
      0x32000004 => 'ramdisksdipath',
      0x35000005 => 'ramdiskimagelength',
      0x36000006 => 'exportascd',
      0x35000007 => 'ramdisktftpblocksize',
      0x35000008 => 'ramdisktftpwindowsize',
      0x36000009 => 'ramdiskmcenabled',
      0x3600000a => 'ramdiskmctftpfallback',
      0x3600000b => 'ramdisktftpvarwindow',
   },
   memdiag => {
      0x25000001 => 'passcount',
      0x25000002 => 'testmix',
      0x25000003 => 'failurecount',
      0x26000003 => 'cacheenable',
      0x25000004 => 'testtofail',
      0x26000004 => 'failuresenabled',
      0x25000005 => 'stridefailcount',
      0x26000005 => 'cacheenable',
      0x25000006 => 'invcfailcount',
      0x25000007 => 'matsfailcount',
      0x25000008 => 'randfailcount',
      0x25000009 => 'chckrfailcount',
   },
   ntldr => {
      0x22000001 => 'bpbstring',
   },
   osloader => {
      0x21000001 => 'osdevice',
      0x22000002 => 'systemroot',
      0x23000003 => 'resumeobject',
      0x26000004 => 'stampdisks',
      0x26000010 => 'detecthal',
      0x22000011 => 'kernel',
      0x22000012 => 'hal',
      0x22000013 => 'dbgtransport',
      0x25000020 => 'nx',
      0x25000021 => 'pae',
      0x26000022 => 'winpe',
      0x26000024 => 'nocrashautoreboot',
      0x26000025 => 'lastknowngood',
      0x26000026 => 'oslnointegritychecks',
      0x26000027 => 'osltestsigning',
      0x26000030 => 'nolowmem',
      0x25000031 => 'removememory',
      0x25000032 => 'increaseuserva',
      0x25000033 => 'perfmem',
      0x26000040 => 'vga',
      0x26000041 => 'quietboot',
      0x26000042 => 'novesa',
      0x26000043 => 'novga',
      0x25000050 => 'clustermodeaddressing',
      0x26000051 => 'usephysicaldestination',
      0x25000052 => 'restrictapiccluster',
      0x22000053 => 'evstore',
      0x26000054 => 'uselegacyapicmode',
      0x26000060 => 'onecpu',
      0x25000061 => 'numproc',
      0x26000062 => 'maxproc',
      0x25000063 => 'configflags',
      0x26000064 => 'maxgroup',
      0x26000065 => 'groupaware',
      0x25000066 => 'groupsize',
      0x26000070 => 'usefirmwarepcisettings',
      0x25000071 => 'msi',
      0x25000072 => 'pciexpress',
      0x25000080 => 'safeboot',
      0x26000081 => 'safebootalternateshell',
      0x26000090 => 'bootlog',
      0x26000091 => 'sos',
      0x260000a0 => 'debug',
      0x260000a1 => 'halbreakpoint',
      0x260000a2 => 'useplatformclock',
      0x260000a3 => 'forcelegacyplatform',
      0x260000a4 => 'useplatformtick',
      0x260000a5 => 'disabledynamictick',
      0x250000a6 => 'tscsyncpolicy',
      0x260000b0 => 'ems',
      0x250000c0 => 'forcefailure',
      0x250000c1 => 'driverloadfailurepolicy',
      0x250000c2 => 'bootmenupolicy',
      0x260000c3 => 'onetimeadvancedoptions',
      0x260000c4 => 'onetimeoptionsedit',
      0x250000e0 => 'bootstatuspolicy',
      0x260000e1 => 'disableelamdrivers',
      0x250000f0 => 'hypervisorlaunchtype',
      0x220000f1 => 'hypervisorpath',
      0x260000f2 => 'hypervisordebug',
      0x250000f3 => 'hypervisordebugtype',
      0x250000f4 => 'hypervisordebugport',
      0x250000f5 => 'hypervisorbaudrate',
      0x250000f6 => 'hypervisorchannel',
      0x250000f7 => 'bootux',
      0x260000f8 => 'hypervisordisableslat',
      0x220000f9 => 'hypervisorbusparams',
      0x250000fa => 'hypervisornumproc',
      0x250000fb => 'hypervisorrootprocpernode',
      0x260000fc => 'hypervisoruselargevtlb',
      0x250000fd => 'hypervisorhostip',
      0x250000fe => 'hypervisorhostport',
      0x250000ff => 'hypervisordebugpages',
      0x25000100 => 'tpmbootentropy',
      0x22000110 => 'hypervisorusekey',
      0x22000112 => 'hypervisorproductskutype',
      0x25000113 => 'hypervisorrootproc',
      0x26000114 => 'hypervisordhcp',
      0x25000115 => 'hypervisoriommupolicy',
      0x26000116 => 'hypervisorusevapic',
      0x22000117 => 'hypervisorloadoptions',
      0x25000118 => 'hypervisormsrfilterpolicy',
      0x25000119 => 'hypervisormmionxpolicy',
      0x2500011a => 'hypervisorschedulertype',
      0x25000120 => 'xsavepolicy',
      0x25000121 => 'xsaveaddfeature0',
      0x25000122 => 'xsaveaddfeature1',
      0x25000123 => 'xsaveaddfeature2',
      0x25000124 => 'xsaveaddfeature3',
      0x25000125 => 'xsaveaddfeature4',
      0x25000126 => 'xsaveaddfeature5',
      0x25000127 => 'xsaveaddfeature6',
      0x25000128 => 'xsaveaddfeature7',
      0x25000129 => 'xsaveremovefeature',
      0x2500012a => 'xsaveprocessorsmask',
      0x2500012b => 'xsavedisable',
      0x2500012c => 'kerneldebugtype',
      0x2200012d => 'kernelbusparams',
      0x2500012e => 'kerneldebugaddress',
      0x2500012f => 'kerneldebugport',
      0x25000130 => 'claimedtpmcounter',
      0x25000131 => 'kernelchannel',
      0x22000132 => 'kerneltargetname',
      0x25000133 => 'kernelhostip',
      0x25000134 => 'kernelport',
      0x26000135 => 'kerneldhcp',
      0x22000136 => 'kernelkey',
      0x22000137 => 'imchivename',
      0x21000138 => 'imcdevice',
      0x25000139 => 'kernelbaudrate',
      0x22000140 => 'mfgmode',
      0x26000141 => 'event',
      0x25000142 => 'vsmlaunchtype',
      0x25000144 => 'hypervisorenforcedcodeintegrity',
      0x21000150 => 'systemdatadevice',
      0x21000151 => 'osarcdevice',
      0x21000153 => 'osdatadevice',
      0x21000154 => 'bspdevice',
      0x21000155 => 'bspfilepath',
   },
   resume => {
      0x21000001 => 'filedevice',
      0x22000002 => 'filepath',
      0x26000003 => 'customsettings',
      0x26000004 => 'pae',
      0x21000005 => 'associatedosdevice',
      0x26000006 => 'debugoptionenabled',
      0x25000007 => 'bootux',
      0x25000008 => 'bootmenupolicy',
      0x26000024 => 'hormenabled',
   },
   startup => {
      0x26000001 => 'pxesoftreboot',
      0x22000002 => 'applicationname',
   },
);

# mask, value => class
our @bcde_typeclass = (
   [0x00000000, 0x00000000, 'any'],
   [0xf00fffff, 0x1000000a, 'bootapp'],
   [0xf0ffffff, 0x2020000a, 'bootapp'],
   [0xf00fffff, 0x10000001, 'bootmgr'],
   [0xf00fffff, 0x10000002, 'bootmgr'],
   [0xf0ffffff, 0x20200001, 'bootmgr'],
   [0xf0ffffff, 0x20200002, 'bootmgr'],
   [0xf0f00000, 0x20300000, 'device'],
   [0xf0000000, 0x30000000, 'device'],
   [0xf00fffff, 0x10000005, 'memdiag'],
   [0xf0ffffff, 0x20200005, 'memdiag'],
   [0xf00fffff, 0x10000006, 'ntldr'],
   [0xf00fffff, 0x10000007, 'ntldr'],
   [0xf0ffffff, 0x20200006, 'ntldr'],
   [0xf0ffffff, 0x20200007, 'ntldr'],
   [0xf00fffff, 0x10000003, 'osloader'],
   [0xf0ffffff, 0x20200003, 'osloader'],
   [0xf00fffff, 0x10000004, 'resume'],
   [0xf0ffffff, 0x20200004, 'resume'],
   [0xf00fffff, 0x10000009, 'startup'],
   [0xf0ffffff, 0x20200009, 'startup'],
);

our %rbcde_byclass;

while (my ($k, $v) = each %bcde_byclass) {
   $rbcde_byclass{$k} = { reverse %$v };
}

# decodes (numerical elem, type) to name
sub dec_bcde_id($$) {
   for my $class (@bcde_typeclass) {
      if (($_[1] & $class->[0]) == $class->[1]) {
         if (my $id = $bcde_byclass{$class->[2]}{$_[0]}) {
            return $id;
         }
      }
   }

   sprintf "custom:%08x", $_[0]
}

# encodes (elem as name, type)
sub enc_bcde_id($$) {
   $_[0] =~ /^custom:(?:0x)?([0-9a-fA-F]{8}$)/
      and return hex $1;

   for my $class (@bcde_typeclass) {
      if (($_[1] & $class->[0]) == $class->[1]) {
         if (my $value = $rbcde_byclass{$class->[2]}{$_[0]}) {
            return $value;
         }
      }
   }

   undef
}

# decode/encode bcd device element - the horror, no documentaion
# whatsoever, supercomplex, superinconsistent.

our @dev_type = qw(block type1 legacypartition serial udp boot partition vmbus locate);
our @block_type = qw(harddisk floppy cdrom ramdisk type4 file vhd);
our @part_type = qw(gpt mbr raw);

our $NULL_DEVICE = "\x00" x 16;

# biggest bitch to decode, ever
# this decodes a device portion after the GUID
sub dec_device_($$);
sub dec_device_($$) {
   my ($device, $type) = @_;

   my $res;

   my ($type, $flags, $length, $pad) = unpack "VVVV", substr $device, 0, 4 * 4, "";

   $pad == 0
      or die "non-zero reserved field in device descriptor\n";

   if ($length == 0 && $type == 0 && $flags == 0) {
      return ("null", $device);
   }

   $length >= 16
      or die "device element size too small ($length)\n";

   $type = $dev_type[$type] // die "$type: unknown device type\n";
   #d#   warn "t<$type,$flags,$length,$pad>\n";#d#

   $res .= $type;
   $res .= sprintf "<%x>", $flags if $flags;

   my $tail = substr $device, $length - 4 * 4, 1e9, "";

   $length == 4 * 4 + length $device
      or die "device length mismatch ($length != " . (16 + length $device) . ")\n";

   my $dec_path = sub {
      my ($path, $error) = @_;

      $path =~ /^((?:..)*)\x00\x00\z/s
         or die "$error\n";

      $path = Encode::decode "UTF-16LE", $1;

      $path
   };

   if ($type eq "partition" or $type eq "legacypartition") {
      my $partdata = substr $device, 0, 16, "";
      my ($blocktype, $parttype) = unpack "VV", substr $device, 0, 4 * 2, "";

      $blocktype = $block_type[$blocktype] // die "unknown block device type '$blocktype'\n";
      $parttype = $part_type[$parttype] // die "unknown partition type\n";

      my $diskid = substr $device, 0, 16, "";

      $diskid = $parttype eq "gpt"
         ? dec_guid substr $diskid, 0, 16
         : sprintf "%08x", unpack "V", $diskid;

      my $partid = $parttype eq "gpt"   ? dec_guid $partdata
                 : $type eq "partition" ? unpack "Q<", $partdata  # byte offset to partition start
                                        : unpack "L<", $partdata; # partition number, one-based

      (my $parent, $device) = dec_device_ $device, $type;

      $res .= "=";
      $res .= "<$parent>";
      $res .= ",$blocktype,$parttype,$diskid,$partid";

      # PartitionType (gpt, mbr, raw)
      # guid | partsig | disknumber

   } elsif ($type eq "boot") {
      $device =~ s/^\x00{56}\z//
         or die "boot device type with extra data not supported\n";
      
   } elsif ($type eq "block") {
      my $blocktype = unpack "V", substr $device, 0, 4, "";

      $blocktype = $block_type[$blocktype] // die "unknown block device type '$blocktype'\n";

      # decode a "file path" structure
      my $dec_file = sub {
         my ($fver, $flen, $ftype) = unpack "VVV", substr $device, 0, 4 * 3, "";

         my $path = substr $device, 0, $flen - 12, "";

         $fver == 1
            or die "unsupported file descriptor version '$fver'\n";

         $ftype == 5
            or die "unsupported file descriptor path type '$type'\n";

         (my $parent, $path) = dec_device_ $path, $type;

         $path = $dec_path->($path, "file device without path");

         ($parent, $path)
      };

      if ($blocktype eq "file") {
         my ($parent, $path) = $dec_file->();

         $res .= "=file,<$parent>,$path";

      } elsif ($blocktype eq "vhd") {
         $device =~ s/^\x00{20}//s
            or die "virtualdisk has non-zero fields I don't understand\n";

         (my $parent, $device) = dec_device_ $device, $type;

         $res .= "=vhd,<$parent>";

      } elsif ($blocktype eq "ramdisk") {
         my ($base, $size, $offset) = unpack "Q< Q< L<", substr $device, 0, 8 + 8 + 4, "";
         my ($subdev, $path) = $dec_file->();

         $res .= "=ramdisk,<$subdev>,$base,$size,$offset,$path";

      } else {
        die "unsupported block type '$blocktype'\n";
      }

   } elsif ($type eq "locate") {
      # mode, bcde_id, unknown, string
      # we assume locate has _either_ an element id _or_ a path, but not both

      my ($mode, $elem, $parent) = unpack "VVV", substr $device, 0, 4 * 3, "";

      if ($parent) {
         # not sure why this is an offset - it must come after the path
         $parent = substr $device, $parent - 4 * 3 - 4 * 4, 1e9, "";
         ($parent, my $tail) = dec_device_ $parent, $type;
         0 == length $tail
            or die "trailing data after locate device parent\n";
      } else {
         $parent = "null";
      }

      my $path = $device; $device = "";
      $path = $dec_path->($path, "device locate mode without path");

      $res .= "=<$parent>,";

      if ($mode == 0) { # "Element"
         !length $path
            or die "device locate mode 0 having non-empty path ($mode, $elem, $path)\n";

         $elem = dec_bcde_id $elem, $type;
         $res .= "element,$elem";

      } elsif ($mode == 1) { # "String"
         !$elem
            or die "device locate mode 1 having non-zero element\n";

         $res .= "path,$path";
      } else {
         # mode 2 maybe called "ElementChild" with element and parent device? example needed
         die "device locate mode '$mode' not supported\n";
      }

   } elsif ($type eq "vmbus") {
      my $type     = dec_guid substr $device, 0, 16, "";
      my $instance = dec_guid substr $device, 0, 16, "";

      $device =~ s/^\x00{24}\z//
         or die "vmbus has non-zero fields I don't understand\n";

      $res .= "=$type,$instance";

   } else {
      die "unsupported device type '$type'\n";
   }

   warn "unexpected trailing device data($res), " . unpack "H*",$device
      if length $device;
   #length $device
   #      and die "unexpected trailing device data\n";

   ($res, $tail)
}

# decode a full binary BCD device descriptor
sub dec_device($$) {
   my ($device, $type) = @_;

   $device = pack "H*", $device;

   my $guid = dec_guid substr $device, 0, 16, "";
   $guid = $guid eq "00000000-0000-0000-0000-000000000000"
      ? "" : "{$guid}";

   eval {
      my ($dev, $tail) = dec_device_ $device, $type;

      $tail eq ""
         or die "unsupported trailing data after device descriptor\n";

      "$guid$dev"
#   } // scalar ((warn $@), "$guid$fallback")
   } // ($guid . "binary=" . unpack "H*", $device)
}

sub indexof($@) {
   my $value = shift;

   for (0 .. $#_) {
      $value eq $_[$_]
         and return $_;
   }

   undef
}

# encode the device portion after the GUID
sub enc_device_($$);
sub enc_device_($$) {
   my ($device, $type) = @_;

   my $enc_path = sub {
      my $path = shift;
      $path =~ s/\//\\/g;
      (Encode::encode "UTF-16LE", $path) . "\x00\x00"
   };

   my $enc_file = sub {
      my ($parent, $path) = @_; # parent and path must already be encoded

      $path = $parent . $path;

      # fver 1, ftype 5
      pack "VVVa*", 1, 12 + length $path, 5, $path
   };

   my $parse_path = sub {
      s/^([\/\\][^<>"|?*\x00-\x1f]*)//
         or die "$_: invalid path\n";

      $enc_path->($1)
   };

   my $parse_parent = sub {
      my $parent;

      if (s/^<//) {
         ($parent, $_) = enc_device_ $_, $type;
         s/^>//
            or die "$device: syntax error: parent device not followed by '>'\n";
      } else {
         $parent = $NULL_DEVICE;
      }

      $parent
   };

   for ($device) {
      s/^([a-z]+)//
         or die "$_: device does not start with type string\n";

      my $type = $1;
      my $flags = s/^<([0-9a-fA-F]+)>// ? hex $1 : 0;
      my $payload;

      if ($type eq "binary") {
         s/^=([0-9a-fA-F]+)//
            or die "binary type must have a hex string argument\n";

         $payload = pack "H*", $1;

      } elsif ($type eq "null") {
         return ($NULL_DEVICE, $_);

      } elsif ($type eq "boot") {
         $payload = "\x00" x 56;

      } elsif ($type eq "partition" or $type eq "legacypartition") {
         s/^=//
            or die "$_: missing '=' after $type\n";

         my $parent = $parse_parent->();

         s/^,//
            or die "$_: comma missing after partition parent device\n";

         s/^([a-z]+),//
            or die "$_: partition does not start with block type (e.g. hd or vhd)\n";
         my $blocktype = $1;

         s/^([a-z]+),//
            or die "$_: partition block type not followed by partiton type\n";
         my $parttype = $1;

         my ($partdata, $diskdata);

         if ($parttype eq "mbr") {
            s/^([0-9a-f]{8}),//i
               or die "$_: partition mbr disk id malformed (must be e.g. 1234abcd)\n";
            $diskdata = pack "Vx12", hex $1;

            s/^([0-9]+)//
               or die "$_: partition number or offset is missing or malformed (must be decimal)\n";

            # the following works for both 64 bit offset and 32 bit partno
            $partdata = pack "Q< x8", $1;

         } elsif ($parttype eq "gpt") {
            s/^($RE_GUID),//
               or die "$_: partition disk guid missing or malformed\n";
            $diskdata = enc_guid $1;

            s/^($RE_GUID)//
               or die "$_: partition guid missing or malformed\n";
            $partdata = enc_guid $1;

         } elsif ($parttype eq "raw") {
            s/^([0-9]+)//
               or die "$_: partition disk number missing or malformed (must be decimal)\n";

            $partdata = pack "L< x12", $1;

         } else {
            die "$parttype: partition type not supported\n";
         }

         $payload = pack "a16 L< L< a16 a*",
            $partdata,
            (indexof $blocktype, @block_type),
            (indexof $parttype, @part_type),
            $diskdata,
            $parent;

      } elsif ($type eq "locate") {
         s/^=//
            or die "$_: missing '=' after $type\n";

         my ($mode, $elem, $path);

         my $parent = $parse_parent->();

         s/^,//
            or die "$_: missing comma after locate parent device\n";

         if (s/^element,//) {
            s/^([0-9a-z:]+)//i
               or die "$_ locate element must be either name or 8-digit hex id\n";
            $elem = enc_bcde_id $1, $type;
            $mode = 0;
            $path = $enc_path->("");

         } elsif (s/^path,//) {
            $mode = 1;
            $path = $parse_path->();
            
         } else {
            die "$_ second locate argument must be subtype (either element or path)\n";
         }

         if ($parent ne $NULL_DEVICE) {
            ($parent, $path) = (4 * 4 + 4 * 3 + length $path, "$path$parent");
         } else {
            $parent = 0;
         }

         $payload = pack "VVVa*", $mode, $elem, $parent, $path;

      } elsif ($type eq "block") {
         s/^=//
            or die "$_: missing '=' after $type\n";

         s/^([a-z]+),//
            or die "$_: block device does not start with block type (e.g. disk)\n";
         my $blocktype = $1;

         my $blockdata;

         if ($blocktype eq "file") {
            my $parent = $parse_parent->();
            s/^,// or die "$_: comma missing after file block device parent\n";
            my $path = $parse_path->();

            $blockdata = $enc_file->($parent, $path);

         } elsif ($blocktype eq "vhd") {
            $blockdata = "\x00" x 20; # ENOTUNDERSTOOD
            $blockdata .= $parse_parent->();

         } elsif ($blocktype eq "ramdisk") {
            my $parent = $parse_parent->();

            s/^,(\d+),(\d+),(\d+),//a
               or die "$_: missing ramdisk base,size,offset after ramdisk parent device\n";

            my ($base, $size, $offset) = ($1, $2, $3);

            my $path = $parse_path->();

            $blockdata = pack "Q< Q< L< a*", $base, $size, $offset, $enc_file->($parent, $path);

         } elsif ($blocktype eq "cdrom" or $blocktype eq "floppy") {
            # this is guesswork
            s/^(\d+)//a
               or die "$_: missing device number for cdrom\n";
            $blockdata = pack "V", $1;

         } else {
            die "$blocktype: unsupported block type (must be file, vhd, ramdisk, floppy, cdrom)\n";
         }

         $payload = pack "Va*",
            (indexof $blocktype, @block_type),
            $blockdata;

      } elsif ($type eq "vmbus") {
         s/^=($RE_GUID)//
            or die "$_: malformed or missing vmbus interface type guid\n";
         my $type = enc_guid $1;
         s/^,($RE_GUID)//
            or die "$_: malformed or missing vmbus interface instance guid\n";
         my $instance = enc_guid $1;

         $payload = pack "a16a16x24", $type, $instance;

#      } elsif ($type eq "udp") {
#         $payload = pack "Va16", 1, "12345678";

      } else {
         die "$type: not a supported device type (binary, null, boot, legacypartition, partition, block, locate)\n";
      }

      return  (
         (pack "VVVVa*", (indexof $type, @dev_type), $flags, 16 + length $payload, 0, $payload),
         $_
      );
   }
}

# encode a full binary BCD device descriptor
sub enc_device($$) {
   my ($device, $type) = @_;

   my $guid = "\x00" x 16;

   if ($device =~ s/^\{([A-Za-z0-9\-]+)\}//) {
      $guid = enc_guid $1
         or die "$device: does not start with valid guid\n";
   }

   my ($descriptor, $tail) = enc_device_ $device, $type;

   length $tail
      and die "$device: garbage after device descriptor\n";

   unpack "H*", $guid . $descriptor
}

# decode a registry hive into the BCD structure used by pbcdedit
sub bcd_decode {
   my ($hive) = @_;

   my %bcd;

   my $objects = $hive->[1][1]{Objects}[1];

   while (my ($k, $v) = each %$objects) {
      my %kv;
      $v = $v->[1];

      $k = $bcd_objects{$k} // $k;

      my $type = $v->{Description}[0]{Type}[1];

      if ($type != $bcd_object_types{$k}) {
         $kv{type} = $bcd_types{$type} // sprintf "0x%08x", $type;
      }

      my $elems = $v->{Elements}[1];

      while (my ($k, $v) = each %$elems) {
         my $k = hex $k;

         my $v = $bcde_dec{$k & BCDE_FORMAT}->($v->[0]{Element}[1], $type);
         my $k = dec_bcde_id $k, $type;

         $kv{$k} = $v;
      }

      $bcd{$k} = \%kv;
   }

   $bcd{meta} = { version => $JSON_VERSION };

   \%bcd
}

# encode a pbcdedit structure into a registry hive
sub bcd_encode {
   my ($bcd) = @_;

   if (my $meta = $bcd->{meta}) {
      $meta->{version} eq $JSON_VERSION
         or die "BCD meta version ($meta->{version}) does not match executable version ($JSON_VERSION)\n";
   }

   my %objects;
   my %rbcd_types = reverse %bcd_types;

   while (my ($k, $v) = each %$bcd) {
      my %kv;

      next if $k eq "meta";

      $k = lc $k; # I know you windows types!

      my $type = $v->{type};

      if ($type) {
         $type = $type =~ /^(?:0x)[0-9a-fA-F]+$/
            ? hex $type
            : $rbcd_types{$type} // die "$type: unable to parse bcd object type\n";
      }

      my $guid = enc_wguid $k
         or die "$k: invalid bcd object identifier\n";

      # default type if not given
      $type //= $bcd_object_types{dec_wguid $guid} // die "$k: unable to deduce bcd object type\n";

      my %elem;

      while (my ($k, $v) = each %$v) {
         next if $k eq "type";

         $k = (enc_bcde_id $k, $type) // die "$k: invalid bcde element name or id\n";
         $elem{sprintf "%08x", $k} = [{
            Element => [ ($bcde_enc{$k & BCDE_FORMAT} // die "$k: unable to encode unknown bcd element type}")->($v)]
         }];
      }

      $guid = dec_guid $guid;

      $objects{"{$guid}"} = [undef, {
         Description => [{ Type => [dword => $type] }],
         Elements => [undef, \%elem],
      }];
   }

   [NewStoreRoot => [undef, {
      Description => [{
         KeyName  => [sz => "BCD00000001"],
         System   => [dword => 1],
         pbcdedit => [sz => $VERSION],
         # other values seen: GuidCache => ..., TreatAsSystem => 0x00000001
      }],
      Objects => [undef, \%objects],
   }]]
}

#############################################################################
# edit instructions

sub bcd_edit_eval {
   package pbcdedit;

   our ($PATH, $BCD, $DEFAULT);

   eval shift;
   die "$@" if $@;
}

sub bcd_edit {
   my ($path, $bcd, @insns) = @_;

   my $default = $bcd->{"{bootmgr}"}{default};

   # prepare "officially visible" variables
   local $pbcdedit::PATH    = $path;
   local $pbcdedit::BCD     = $bcd;
   local $pbcdedit::DEFAULT = $default;

   while (@insns) {
      my $insn = shift @insns;

      if ($insn eq "get") {
         my $object = shift @insns;
         my $elem   = shift @insns;

         $object = $object eq "{default}" ? $default : dec_wguid enc_wguid $object;

         print $bcd->{$object}{$elem}, "\n";

      } elsif ($insn eq "set") {
         my $object = shift @insns;
         my $elem   = shift @insns;
         my $value  = shift @insns;

         $object = $object eq "{default}" ? $default : dec_wguid enc_wguid $object;

         $bcd->{$object}{$elem} = $value;

      } elsif ($insn eq "del") {
         my $object = shift @insns;
         my $elem   = shift @insns;

         $object = $object eq "{default}" ? $default : dec_wguid enc_wguid $object;

         delete $bcd->{$object}{$elem};

      } elsif ($insn eq "eval") {
         my $perl = shift @insns;
         bcd_edit_eval "#line 1 'eval'\n$perl";

      } elsif ($insn eq "do") {
         my $path = shift @insns;
         my $file = file_load $path;
         bcd_edit_eval "#line 1 '$path'\n$file";

      } else {
         die "$insn: not a recognized instruction for create/edit/parse\n";
      }
   }

}

#############################################################################
# other utilities

# json to stdout
sub prjson($) {
   print $json_coder->encode ($_[0]);
}

# json from stdin
sub rdjson() {
   my $json;
   1 while read STDIN, $json, 65536, length $json;
   $json_coder->decode ($json)
}

sub lsblk() {
   my $lsblk = $json_coder->decode (scalar qx<lsblk --json -o PATH,KNAME,MAJ:MIN,TYPE,PTTYPE,PTUUID,PARTUUID,LABEL,FSTYPE>);

   for my $dev (@{ $lsblk->{blockdevices} }) {
      if ($dev->{type} eq "part") {

         # lsblk sometimes gives a bogus pttype, so we recreate it here
         $dev->{pttype} = $dev->{ptuuid} =~ /^$RE_GUID\z/
            ? "gpt" : "dos";

         if ($dev->{pttype} eq "gpt") {
            $dev->{bcd_device} = "partition=<null>,harddisk,gpt,$dev->{ptuuid},$dev->{partuuid}";
         } elsif ($dev->{pttype} eq "dos") { # why not "mbr" :(
            if ($dev->{partuuid} =~ /^([0-9a-f]{8})-([0-9a-f]{2})\z/i) {
               my ($diskid, $partno) = ($1, hex $2);
               $dev->{bcd_legacy_device} = "legacypartition=<null>,harddisk,mbr,$diskid,$partno";
               if (open my $fh, "/sys/class/block/$dev->{kname}/start") {
                  my $start = 512 * readline $fh;
                  $dev->{bcd_device} = "partition=<null>,harddisk,mbr,$diskid,$start";
               }
            }
         }
      }
   }

   $lsblk->{blockdevices}
}

sub prdev($$) {
   my ($path, $attribute) = @_;

   # rather than stat'ing and guessing how devices are encoded, we use lsblk for this
   my $mm = $json_coder->decode (scalar qx<lsblk -d -o MAJ:MIN -J \Q$path\E>)->{blockdevices}[0]{"maj:min"};

   my $lsblk = lsblk;

   for my $dev (@$lsblk) {
      if ($dev->{"maj:min"} eq $mm && $dev->{$attribute}) {
         say $dev->{$attribute};
         exit 0;
      }
   }

   exit 1;
}

#############################################################################
# command line parser

our %CMD = (
   help => sub {
      require Pod::Usage;
      Pod::Usage::pod2usage (-verbose => 2, -quotes => "none", -noperldoc => 1);
   },

   objects => sub {
      my %rbcd_types = reverse %bcd_types;
      $_ = sprintf "%08x", $_ for values %rbcd_types;

      if ($_[0] eq "--json") {
         my %default_type = %bcd_object_types;
         $_ = sprintf "%08x", $_ for values %default_type;

         prjson {
            version             => $JSON_VERSION,
            object_alias        => \%bcd_objects,
            object_type         => \%rbcd_types,
            object_default_type => \%default_type,
         };
      } else {
         my %rbcd_objects = reverse %bcd_objects;

         print "\n";

         printf "%-9s %s\n", "Type", "Alias";
         for my $tname (sort keys %rbcd_types) {
            printf "%-9s %s\n", $rbcd_types{$tname}, $tname;
         }

         print "\n";

         printf "%-39s %-23s %s\n", "Object GUID", "Alias", "(Hex) Default Type";
         for my $name (sort keys %rbcd_objects) {
            my $guid  = $rbcd_objects{$name};
            my $type  = $bcd_object_types{$name};
            my $tname = $bcd_types{$type};

            $type = $type ? sprintf "(%08x) %s", $type, $tname : "-";

            printf "%-39s %-23s %s\n", $guid, $name, $type;
         }

         print "\n";
      }
   },

   elements => sub {
      my $json = $_[0] eq "--json";

      my %format_name = (
         BCDE_FORMAT_DEVICE      , "device",
         BCDE_FORMAT_STRING      , "string",
         BCDE_FORMAT_GUID        , "guid",
         BCDE_FORMAT_GUID_LIST   , "guid list",
         BCDE_FORMAT_INTEGER     , "integer",
         BCDE_FORMAT_BOOLEAN     , "boolean",
         BCDE_FORMAT_INTEGER_LIST, "integer list",
      );

      my @element;

      for my $class (sort keys %rbcde_byclass) {
         my $rbcde = $rbcde_byclass{$class};

         unless ($json) {
            print "\n";
            printf "Elements applicable to class(es): $class\n";
            printf "%-9s %-12s %s\n", "Element", "Format", "Name Alias";
         }
         for my $name (sort keys %$rbcde) {
            my $id = $rbcde->{$name};
            my $format = $format_name{$id & BCDE_FORMAT};

            if ($json) {
               push @element, [$class, $id * 1, $format, $name];
            } else {
               $id = sprintf "%08x", $id;
               printf "%-9s %-12s %s\n", $id, $format, $name;
            }
         }
      }
      print "\n" unless $json;

      prjson {
         version => $JSON_VERSION,
         element => \@element,
         class   => \@bcde_typeclass,
      } if $json;

   },

   export => sub {
      prjson bcd_decode regf_load shift;
   },

   import => sub {
      regf_save shift, bcd_encode rdjson;
   },

   create => sub {
      my $path = shift;
      my $stat = stat_get $path; # should actually be done at file load time
      my $bcd = { };
      bcd_edit $path, $bcd, @_;
      regf_save $path, bcd_encode $bcd;
      stat_set $path, $stat;
   },

   edit => sub {
      my $path = shift;
      my $stat = stat_get $path; # should actually be done at file load time
      my $bcd = bcd_decode regf_load $path;
      bcd_edit $path, $bcd, @_;
      regf_save $path, bcd_encode $bcd;
      stat_set $path, $stat;
   },

   parse => sub {
      my $path = shift;
      my $bcd = bcd_decode regf_load $path;
      bcd_edit $path, $bcd, @_;
   },

   "export-regf" => sub {
      prjson regf_load shift;
      
   },

   "import-regf" => sub {
      regf_save shift, rdjson;
   },

   lsblk => sub {
      my $json = $_[0] eq "--json";

      my $lsblk = lsblk;

      if ($json) {
         prjson $lsblk;
      } else {
         printf "%-10s %-8.8s %-6.6s %-3s %s\n", "DEVICE", "LABEL", "FSTYPE", "PT", "DEVICE DESCRIPTOR";
         for my $dev (@$lsblk) {
            for my $bcd ($dev->{bcd_device}, $dev->{bcd_legacy_device}) {
               printf "%-10s %-8.8s %-6.6s %-3s %s\n",
                     $dev->{path}, $dev->{label}, $dev->{fstype}, $dev->{pttype}, $bcd
                  if $bcd;
            }
         }
      }
   },

   "bcd-device" => sub {
      prdev shift, "bcd_device";
   },

   "bcd-legacy-device" => sub {
      prdev shift, "bcd_legacy_device";
   },

   version => sub {
      print "\n",
            "PBCDEDIT version $VERSION, copyright 2019 Marc A. Lehmann <pbcdedit\@schmorp.de>.\n",
            "JSON schema version: $JSON_VERSION\n",
            "Licensed under the GNU General Public License Version 3.0, or any later version.\n",
            "\n",
            $CHANGELOG,
            "\n";
   },
);

my $cmd = shift;

unless (exists $CMD{$cmd}) {
   warn "Usage: $0 subcommand args...\nTry $0 help\n";
   exit 126;
}

$CMD{$cmd}->(@ARGV);

Revision:	1.77
Committed:	Tue Aug 9 12:09:03 2022 UTC (21 months, 1 week ago) by root
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.76:	+1 -1 lines
Log Message:	* empty log message *