view release on metacpan or  search on metacpan

lib/ChordPro/Config.pm  view on Meta::CPAN

    # Write if out.
    if ( $to && $to ne "-" ) {
	open( my $fd, '>', $to )
	  or die("$to: $!\n");
	print $fd $res;
	$fd->close;
    }
    else {
	print $res;
    }

    1;
}

# Config in properties format.

sub cfg2props ( $o, $path = "" ) {
    $path //= "";
    my $ret = "";
    if ( !defined $o ) {
        $ret .= "$path: undef\n";
    }
    elsif ( is_hashref($o) ) {
        $path .= "." unless $path eq "";
        for ( sort keys %$o ) {
            $ret .= cfg2props( $o->{$_}, $path . $_  );
        }
    }
    elsif ( is_arrayref($o) ) {
        $path .= "." unless $path eq "";
        for ( my $i = 0; $i < @$o; $i++ ) {
            $ret .= cfg2props( $o->[$i], $path . "$i" );
        }
    }
    elsif ( $o =~ /^\d+$/ ) {
        $ret .= "$path: $o\n";
    }
    else {
        $o =~ s/\\/\\\\/g;
        $o =~ s/"/\\"/g;
        $o =~ s/\n/\\n/;
        $o =~ s/\t/\\t/;
        $o =~ s/([^\x00-\xff])/sprintf("\\x{%x}", ord($1))/ge;
        $ret .= "$path: \"$o\"\n";
    }

    return $ret;
}

# Locking/unlocking. Locking the hash is mainly for development, to
# trap accidental modifications and typos.

sub lock ( $self ) {
    Hash::Util::lock_hashref_recurse($self);
}

sub unlock ( $self ) {
    Hash::Util::unlock_hashref_recurse($self);
}

sub is_locked ( $self ) {
    Hash::Util::hashref_locked($self);
}

# Augment / Reduce.

sub augment ( $self, $hash ) {

    my $locked = $self->is_locked;
    $self->unlock if $locked;

    $self->_augment( $hash, "" );

    $self->lock if $locked;

    $self;
}


sub _augment ( $self, $hash, $path ) {

    for my $key ( keys(%$hash) ) {

        warn("Config augment error: unknown item $path$key\n")
          unless exists $self->{$key}
            || $path =~ /^pdf\.(?:info|fonts|fontconfig)\./
            || $path =~ /^pdf\.formats\.\w+-even\./
            || $path =~ /^(meta|gridstrum\.symbols)\./
            || $path =~ /^markup\.shortcodes\./
            || $path =~ /^delegates\./
            || $key =~ /^_/;

        # Hash -> Hash.
        # Hash -> Array.
        if ( ref($hash->{$key}) eq 'HASH' ) {
            if ( ref($self->{$key}) eq 'HASH' ) {

                # Hashes. Recurse.
                _augment( $self->{$key}, $hash->{$key}, "$path$key." );
            }
            elsif ( ref($self->{$key}) eq 'ARRAY' ) {

                # Hash -> Array.
                # Update single array element using a hash index.
                foreach my $ix ( keys(%{$hash->{$key}}) ) {
                    die unless $ix =~ /^\d+$/;
                    $self->{$key}->[$ix] = $hash->{$key}->{$ix};
                }
            }
            else {
                # Overwrite.
                $self->{$key} = $hash->{$key};
            }
        }

        # Array -> Array.
        elsif ( ref($hash->{$key}) eq 'ARRAY'
                and ref($self->{$key}) eq 'ARRAY' ) {

            # Arrays. Overwrite or append.
            if ( @{$hash->{$key}} ) {
                my @v = @{ $hash->{$key} };
                if ( $v[0] eq "append" ) {
                    shift(@v);
                    # Append the rest.
                    push( @{ $self->{$key} }, @v );
                }
                elsif ( $v[0] eq "prepend" ) {
                    shift(@v);
                    # Prepend the rest.
                    unshift( @{ $self->{$key} }, @v );
                }
                else {
                    # Overwrite.
                    $self->{$key} = $hash->{$key};
                }
            }
            else {
                # Overwrite.
                $self->{$key} = $hash->{$key};
            }
        }

        else {
            # Overwrite.
            $self->{$key} = $hash->{$key};
        }
    }

    $self;
}

use constant DEBUG => 0;

sub reduce ( $self, $hash ) {

    my $locked = $self->is_locked;

    warn("O: ", qd($hash,1), "\n") if DEBUG > 1;
    warn("N: ", qd($self,1), "\n") if DEBUG > 1;
    my $state = _reduce( $self, $hash, "" );

    $self->lock if $locked;

    warn("== ", qd($self,1), "\n") if DEBUG > 1;
    return $self;
}

sub _ref ( $self ) {
    reftype($self) // ref($self);
}

sub _reduce ( $self, $orig, $path ) {

    my $state;

    if ( _ref($self) eq 'HASH' && _ref($orig) eq 'HASH' ) {

        warn("D: ", qd($self,1), "\n")  if DEBUG && !%$orig;
        return 'D' unless %$orig;

        my %hh = map { $_ => 1 } keys(%$self), keys(%$orig);
        for my $key ( sort keys(%hh) ) {

            warn("Config reduce error: unknown item $path$key\n")
              unless exists $self->{$key}
                || $key =~ /^_/
                || $path =~ /^pdf\/\.fonts\./;

            unless ( exists $orig->{$key} ) {
                warn("D: $path$key\n") if DEBUG;
                delete $self->{$key};
                $state //= 'M';
                next;
            }

            # Hash -> Hash.
            if (     _ref($orig->{$key}) eq 'HASH'
                 and _ref($self->{$key}) eq 'HASH'
                 or
                     _ref($orig->{$key}) eq 'ARRAY'
                 and _ref($self->{$key}) eq 'ARRAY' ) {
                # Recurse.
                my $m = _reduce( $self->{$key}, $orig->{$key}, "$path$key." );
                delete $self->{$key} if $m eq 'D' || $m eq 'I';
                $state //= 'M' if $m ne 'I';
            }

            elsif ( ($self->{$key}//'') eq ($orig->{$key}//'') ) {
                warn("I: $path$key\n") if DEBUG;
                delete $self->{$key};
            }
            elsif (     !defined($self->{$key})
                    and _ref($orig->{$key}) eq 'ARRAY'
                    and !@{$orig->{$key}}
                    or
                        !defined($orig->{$key})
                    and _ref($self->{$key}) eq 'ARRAY'
                    and !@{$self->{$key}} ) {
                # Properties input [] yields undef.
                warn("I: $path$key\n") if DEBUG;
                delete $self->{$key};
            }