File Coverage

lib/File/ValueFile/Simple/Writer.pm

Criterion	Covered	Total	%
statement	76	325	23.3
branch	16	190	8.4
condition	3	84	3.5
subroutine	13	26	50.0
pod	15	15	100.0
total	123	640	19.2

# Copyright (c) 2024-2025 Philipp Schafft

# licensed under Artistic License 2.0 (see LICENSE file)

# ABSTRACT: module for reading and writing ValueFile files

package File::ValueFile::Simple::Writer;

use v5.10;
use strict;
use warnings;

use parent qw(Data::Identifier::Interface::Userdata Data::Identifier::Interface::Subobjects);

use Carp;
use URI::Escape qw(uri_escape uri_escape_utf8);
use Data::Identifier v0.03;

use File::ValueFile;

use constant {
    FORMAT_ISE     => '54bf8af4-b1d7-44da-af48-5278d11e8f32',
    SF_ISE         => 'e5da6a39-46d5-48a9-b174-5c26008e208e', # tagpool-source-format
    TLv1_ISE       => 'afdb46f2-e13f-4419-80d7-c4b956ed85fa', # tagpool-taglist-format-v1
    F_M_L_ISE      => 'f06c2226-b33e-48f2-9085-cd906a3dcee0', # tagpool-source-format-modern-limited
    F_M_F_ISE      => '1c71f5b1-216d-4a9b-81a1-54dc22d8a067', # tagpool-source-format-modern-full
    DOT_REPEAT_ISE => '2ec67bbe-4698-4a0c-921d-1f0951923ee6',
};

my %_default_style = (
    generator_hint              => 'auto',
    tag_relation                => 'tag-relation',
    degenerate_generator_hint   => undef,
    tag_ise_no_ise_retry        => undef,
    tag_ise_no_ise_one          => 1,
    tag_ise_no_ise_no_uriid     => 1,
    comment_column              => 168,
);

my %_generator_comments = (
    '97b7f241-e1c5-4f02-ae3c-8e31e501e1dc' => 'gregorian-date',
    '7da02209-0cf5-4bd2-9ce9-50bd0b7d76e3' => 'owner',
    '5714e8d8-913a-4193-9de0-eb6ba9e13e1f' => 'favourite',
    '283511f7-1c0d-44d4-abd8-6ed1e1fc5d66' => 'like',
    'fd7eb1c9-2840-467c-a77b-afa6f925f0c3' => 'dislike',
    'f2bd1194-d658-4741-b1b1-b4cfd0d6ddea' => 'todo',
    'bd471aca-8b37-483c-8569-a84444b34cfc' => 'background',
    'd511f370-0e49-42d5-ad18-bf280dc97e08' => 'body',
    'bd1a1966-2e71-43cc-a7ce-f7a4547df450' => 'character',
    'f616e3e2-7779-4172-ae26-865b979b4d0c' => 'artist',
    'ee60545c-5415-474d-abe9-6de941045460' => 'fertilization',
    '2b85ca08-921c-4683-a102-f18748c88fda' => 'birth',
    '3e1c709e-32bf-4943-a9fa-8c25cb37dc92' => 'death',
    '8b864ce6-e034-432d-8803-c95cd6da53b6' => 'tagcombiner',
);

my %_old_style_relation = (
    '7f265548-81dc-4280-9550-1bd0aa4bf748' => 'tag-type',
    'e48cd5c6-83d7-411e-9640-cb370f3502fc' => 'tag-implies',
    'd926eb95-6984-415f-8892-233c13491931' => 'tag-links',
);

our $VERSION = v0.10;



sub new {
    my ($pkg, $out, %opts) = @_;
    my $fh;
    my $self = bless \%opts;
    my $_is_utf8;
    my %features;

    if (ref $out) {
        $fh = $out;
    } else {
        open($fh, '>', $out) or croak $!;
    }

    {
        my $style = delete $opts{style};
        $self->{style} = {%_default_style};
        $self->style(%{$style}) if defined $style;
    }

    $self->{fh} = $fh;
    $self->{features} = \%features;
    $self->{escape} = \&uri_escape; # set here, so we can write the markers.

    if (defined $opts{format}) {
        my $format = $self->{format} = Data::Identifier->new(from => $opts{format});

        $self->_write_marker(required => 'ValueFile', FORMAT_ISE, $format);
        $_is_utf8 ||= File::ValueFile->_is_utf8($format);
    }

    foreach my $type (qw(required copy optional)) {
        my $list = $opts{$type.'_feature'} // next;
        $list = [$list] unless ref($list) eq 'ARRAY';
        foreach my $entry (@{$list}) {
            my $feature = Data::Identifier->new(from => $entry);

            $self->{dot_repreat} ||= $feature->eq(DOT_REPEAT_ISE);

            $self->_write_marker($type, 'Feature', $feature);
            $_is_utf8 ||= File::ValueFile->_is_utf8($feature);
            $features{$feature->ise} = $feature;
        }
    }

    $opts{utf8} //= 'auto';

    if ($opts{utf8} eq 'auto') {
        $opts{utf8} = $_is_utf8;
    }

    $self->{escape} = $opts{utf8} ? \&uri_escape_utf8 : \&uri_escape;

    return $self;
}


sub format {
    my ($self, %opts) = @_;

    if (defined $self->{format}) {
        return $self->{format}->as($opts{as}, so => $self) if defined $opts{as};
        return $self->{format};
    }

    return $opts{default} if exists $opts{default};
    croak 'No value for format';
}


sub features {
    my ($self, %opts) = @_;
    return values %{$self->{features}};
}


sub style {
    my ($self, @args) = @_;

    if (scalar(@args) == 1) {
        return $self->{style}{$args[0]};
    } elsif ((scalar(@args) & 1) == 0) {
        my %merge = @args;
        foreach my $key (keys %merge) {
            croak 'Invalid style: '.$key unless exists $_default_style{$key};
            $self->{style}{$key} = $merge{$key};
        }
        return undef;
    }

    croak 'Invalid call (bad arguments?)';
}

sub _escape {
    my ($self, $in) = @_;

    return '!null' if !defined $in;
    return '!empty' if $in eq '';

    return $self->{escape}->($in);
}

sub _write_marker {
    my ($self, $type, @line) = @_;

    $self->{last_line} = undef;

    if ($type eq 'required') {
        $self->{fh}->print('!!');
    } elsif ($type eq 'copy') {
        $self->{fh}->print('!&');
    } elsif ($type eq 'optional') {
        $self->{fh}->print('!?');
    } else {
        croak 'Bug: Bad marker: '.$type;
    }

    @line = map {$self->_escape($_)} map {ref($_) ? $_->ise : $_} @line;

    local $, = ' ';
    $self->{fh}->say(@line);
}


sub write {
    my ($self, @line) = @_;

    unless (scalar @line) {
        $self->{fh}->say('');
        return;
    }

    @line = map {ref($_) ? $_->ise : $_} @line;

    if ($self->{dot_repreat}) {
        my $line = [@line];
        if (defined(my $last_line = $self->{last_line})) {
            my $x = 0;
            foreach my $e (@line) {
                if (defined $e) {
                    if (defined($last_line->[$x]) && $e eq $last_line->[$x]) {
                        $e = '.';
                    } elsif ($e =~ /^\.+$/) {
                        $e .= '.';
                    }
                } elsif (!defined($last_line->[$x])) {
                    $e = '.';
                }
                $x++;
            }
        } else {
            foreach my $e (@line) {
                if (defined $e) {
                    if ($e =~ /^\.+$/) {
                        $e .= '.';
                    }
                }
            }
        }
        $self->{last_line} = $line;
    }

    @line = map {$self->_escape($_)} @line;

    {
        my $l = length($line[0]);
        $line[0] .= ' ' x (19 - $l) if $l < 19;
    }

    local $, = ' ';
    if ($self->{no_eol}) {
        if (defined(my $width = $self->{style}{comment_column})) {
            my $line = join($,, @line);
            my $l = length($line);
            $width--;
            $line .= ' ' x ($width - $l) if $width > $l;
            @line = ($line);
        }
        $self->{fh}->print(@line);
    } else {
        $self->{fh}->say(@line);
    }
}


sub write_with_comment {
    my ($self, @line) = @_;
    my $comment = pop(@line);
    my $valid_comment = defined($comment) && length($comment);

    croak 'Unsupported comment: Bad characters' if $valid_comment && $comment =~ /[\x00-\x1F]/;

    if (scalar(@line)) {
        local $self->{no_eol} = $valid_comment;
        $self->write(@line);
        $self->{fh}->print(' ') if $valid_comment;
    }

    if ($valid_comment) {
        $self->{fh}->say('# ', $comment);
    }
}


sub write_blank {
    my ($self) = @_;
    return $self->write;
}


sub write_comment {
    my ($self, @comment) = @_;

    foreach my $comment_line (map {split /[\r\n]/} grep {defined} @comment) {
        croak 'Unsupported comment: Bad characters' if $comment_line =~ /[\x00-\x1F]/;
        $self->{fh}->say('# ', $comment_line);
    }
}


sub write_hash {
    my ($self, $hash) = @_;

    foreach my $key (keys %{$hash}) {
        my $value = $hash->{$key};

        $value = [$value] unless ref($value) eq 'ARRAY';

        foreach my $entry (@{$value}) {
            $self->write($key => $entry);
        }
    }
}


sub write_taglist {
    my ($self, @list) = @_;
    my $format = $self->format;
    my $mode;

    if ($format->eq(SF_ISE)) { # tagpool-source-format
        if (defined $self->{features}{F_M_L_ISE()}) { # tagpool-source-format-modern-limited
            $mode = 'tag-ise';
        } elsif (defined $self->{features}{F_M_F_ISE()}) { # tagpool-source-format-modern-full
            $mode = 'full';
        } else {
            $mode = 'tag';
        }
    } elsif ($format->eq(TLv1_ISE)) { # tagpool-taglist-format-v1
        $mode = 'tag';
    } else {
        croak 'Unsupported format';
    }

    if ($mode eq 'full') {
        foreach my $sublist (@list) {
            $sublist = [$sublist] unless ref($sublist) eq 'ARRAY';
            foreach my $id (@{$sublist}) {
                $self->write_tag_ise($id);
            }
        }
    } else {
        foreach my $sublist (@list) {
            $sublist = [$sublist] unless ref($sublist) eq 'ARRAY';
            foreach my $id (@{$sublist}) {
                $self->write($mode, Data::Identifier->new(from => $id)->uuid);
            }
        }
    }
}


sub write_tag_ise {
    my ($self, @ids) = @_;
    my $displayname;
    my %collected = (uuid => {}, oid => {}, uri => {});

    @ids = map {ref($_) eq 'ARRAY' ? @{$_} : $_} @ids;

    foreach my $id (@ids) {
        my $found_for_id;

        $id = Data::Identifier->new(ise => $id) unless ref $id;

        $displayname //= $id->displayname(default => undef, no_defaults => 1);

        foreach my $key (qw(uuid oid uri)) {
            my $func = $id->can($key);
            my $value = $id->$func(default => undef, no_defaults => 1, as => $key);
            if (defined $value) {
                $collected{$key}{$value} = undef;
                $found_for_id = 1;
            }
        }

        unless ($found_for_id) {
            if (defined(my $retry = $self->{style}{tag_ise_no_ise_retry})) {
                my @list = map {$_ eq 'all' || $_ eq 'ise' ? qw(uuid oid uri) : ($_)} ref($retry) ? @{$retry} : split(/\s*,\s*|\s+/, $retry);

                foreach my $key (@list) {
                    my $func = $id->can($key) // croak 'Bad value for retry: '.$key;
                    my $value = $id->$func(default => undef, as => $key);
                    if (defined $value) {
                        next if $value =~ m#^https://uriid\.org/# && $self->{style}{tag_ise_no_ise_no_uriid};
                        $collected{$key}{$value} = undef;
                        $found_for_id = 1;
                        last if $self->{style}{tag_ise_no_ise_one};
                    }
                }

                croak 'No ISE found (after retry) for one of the ids' unless $found_for_id;
            } else {
                croak 'No ISE found for one of the ids' unless $found_for_id;
            }
        }
    }

    croak 'No ISEs found' unless scalar(keys(%{$collected{uuid}})) + scalar(keys(%{$collected{oid}})) +  scalar(keys(%{$collected{uri}}));

    local $self->{style}{comment_column} = undef;
    $self->write_with_comment('tag-ise', keys(%{$collected{uuid}}), keys(%{$collected{oid}}), keys(%{$collected{uri}}), $displayname);
}


sub write_tag_relation {
    my ($self, @args) = @_;
    my ($tag, $relation, $related, $context, $filter);
    my %opts;
    my $comment;

    if (scalar(@args) == 1) {
        my $ref = ref($args[0]);
        if ($ref eq 'HASH') {
            return $self->write_tag_relation(%{$args[0]});
        } elsif ($ref eq 'ARRAY') {
            return $self->write_tag_relation(@{$args[0]});
        } else {
            $tag        = $args[0]->tag(default => undef, no_defaults => 1);
            $relation   = $args[0]->relation(default => undef, no_defaults => 1);
            $related    = $args[0]->related(default => undef, no_defaults => 1);
            $context    = $args[0]->context(default => undef, no_defaults => 1);
            $filter     = $args[0]->filter(default => undef, no_defaults => 1);
        }
    } elsif (scalar(@args) == 3 || scalar(@args) == 5) {
        ($tag, $relation, $related, $context, $filter) = @args;
    } elsif ((scalar(@args) % 2) == 0) {
        %opts       = @args;

        $tag        = $opts{tag};
        $relation   = $opts{relation};
        $related    = $opts{related};
        $context    = $opts{context};
        $filter     = $opts{filter};
    } else {
        croak 'Invalid argument configuration';
    }

    croak 'No tag given'        unless defined $tag;
    croak 'No relation given'   unless defined $relation;
    croak 'No related given'    unless defined $related;

    # Ensure types and well formatting:
    foreach my $ent ($tag, $relation, $related, $context, $filter) {
        next unless defined $ent;
        $ent = Data::Identifier->new(ise => $ent) unless ref $ent;
    }

    {
        my $displayname_relation = $relation->displayname(default => undef, no_defaults => 1);
        my $displayname_related  = $related->displayname(default => undef, no_defaults => 1);

        if (defined($displayname_relation) && defined($displayname_related)) {
            $comment = sprintf('%s: %s', $displayname_relation, $displayname_related);
        } elsif (defined($displayname_relation)) {
            $comment = $displayname_relation;
        } elsif (defined($displayname_related)) {
            $comment = '?: '.$displayname_related;
        }
    }

    if ($self->{style}{tag_relation} eq 'mixed' && !defined($context) && !defined($filter) && defined(my $old_style = $_old_style_relation{$relation->ise})) {
        $self->write_with_comment($old_style, $tag, $related, $comment);
        return;
    }

    $self->write_with_comment('tag-relation', $tag, $relation, $related, $context, $filter, $comment);
}


sub write_tag_metadata {
    my ($self, @args) = @_;
    my ($tag, $relation, $context, $type, $encoding, $data_raw);
    my %opts;
    my $comment;

    if (scalar(@args) == 1) {
        my $ref = ref($args[0]);
        if ($ref eq 'HASH') {
            return $self->write_tag_metadata(%{$args[0]});
        } elsif ($ref eq 'ARRAY') {
            return $self->write_tag_metadata(@{$args[0]});
        } else {
            $tag        = $args[0]->tag(default => undef, no_defaults => 1);
            $relation   = $args[0]->relation(default => undef, no_defaults => 1);
            $context    = $args[0]->context(default => undef, no_defaults => 1);
            $type       = $args[0]->type(default => undef, no_defaults => 1);
            $encoding   = $args[0]->encoding(default => undef, no_defaults => 1);
            $data_raw   = $args[0]->data_raw(default => undef, no_defaults => 1);
        }
    } elsif (scalar(@args) == 3) {
        ($tag, $relation, $data_raw) = @args;
    } elsif (scalar(@args) == 5) {
        ($tag, $relation, $type, $encoding, $data_raw) = @args;
    } elsif ((scalar(@args) % 2) == 0) {
        %opts       = @args;

        $tag        = $opts{tag};
        $relation   = $opts{relation};
        $context    = $opts{context};
        $type       = $opts{type};
        $encoding   = $opts{encoding};
        $data_raw   = $opts{data_raw};
    } else {
        croak 'Invalid argument configuration';
    }

    croak 'No tag given'        unless defined $tag;
    croak 'No relation given'   unless defined $relation;
    croak 'No data_raw given'   unless defined $data_raw;

    # Ensure types and well formatting:
    foreach my $ent ($tag, $relation, $context, $type, $encoding) {
        next unless defined $ent;
        $ent = Data::Identifier->new(ise => $ent) unless ref $ent;
    }

    $comment = $relation->displayname(default => undef, no_defaults => 1);
    if (defined($comment) && defined($type) && defined(my $type_displayname = $type->displayname(default => undef, no_defaults => 1))) {
        $comment .= '('.$type_displayname.')';
    }

    $self->write_with_comment('tag-metadata', $tag, $relation, $context, $type, $encoding, $data_raw, $comment);
}


sub write_tag_generator_hint {
    my ($self, $tag, $generator, $hint, $comment) = @_;

    $generator //= Data::Identifier->new(from => $tag)->generator(default => undef);
    $hint      //= Data::Identifier->new(from => $tag)->request(default => undef);

    if (ref($hint) eq 'ARRAY') {
        $hint = join('--', sort map {$_->uuid} @{$hint});
    }

    if ((!defined($generator) || !defined($hint)) && ($self->{style}{degenerate_generator_hint} // '') eq 'auto') {
        $self->write_tag_ise($tag);
        return;
    }

    croak 'No generator given' unless defined $generator;
    croak 'No hint given' unless defined $hint;

    if (
        $self->{style}{generator_hint} eq 'auto' &&
        (
            defined($self->{features}{F_M_L_ISE()}) ||  # tagpool-source-format-modern-limited
            defined($self->{features}{F_M_F_ISE()})     # tagpool-source-format-modern-full
        )
    ) {
        state $generator_request = Data::Identifier->new(uuid => 'ab573786-73bc-4f5c-9b03-24ef8a70ae45')->register;
        state $generated_by      = Data::Identifier->new(uuid => '8efbc13b-47e5-4d92-a960-bd9a2efa9ccb')->register;

        $self->write_tag_metadata($tag, $generator_request, $hint);
        $self->write_tag_relation($tag, $generated_by, Data::Identifier->new(from => $generator));
    } else {
        if (defined $generator) {
            $comment //= $_generator_comments{ref($generator) ? $generator->ise : $generator};
        }

        if (defined $comment) {
            $self->write_with_comment('tag-generator-hint', $tag, $generator, $hint, $comment);
        } else {
            $self->write('tag-generator-hint', $tag, $generator, $hint);
        }
    }
}


sub write_tagname {
    my ($self, $tag, $tagname) = @_;

    return unless defined($tagname) && length($tagname);

    if (
        defined($self->{features}{F_M_L_ISE()}) ||  # tagpool-source-format-modern-limited
        defined($self->{features}{F_M_F_ISE()})     # tagpool-source-format-modern-full
    ) {
        state $wk_asi       = Data::Identifier->new(uuid => 'ddd60c5c-2934-404f-8f2d-fcb4da88b633')->register;
        state $wk_tagname   = Data::Identifier->new(uuid => 'bfae7574-3dae-425d-89b1-9c087c140c23')->register;


        $self->write_tag_metadata($tag, $wk_asi, $wk_tagname, undef, $tagname);
    } else {
        $self->write('tag', $tag, $tagname);
    }
}

1;

__END__