view release on metacpan or  search on metacpan

lib/Qgoda/Util.pm  view on Meta::CPAN

    return if empty $first_line;
    return if $first_line !~ /---[ \t]*\n$/o;
    my $lines = 1;

    while (1) {
        ++$lines;
        my $line = <$fh>;
        return if !defined $line;
        last if $line =~ /---[ \t]*\n$/o;
    }

    local $/;

    my $front_matter = "$placeholder" x $lines;

    return $front_matter . <$fh>;
}

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

    my (undef, $directory) = fileparse $path;
    make_path $directory unless -e $directory;

    my $octets;
    if (Encode::is_utf8($data)) {
         my $handle_malformed = sub {
             my $replacement = sprintf "{{+%04X}}", shift;
             warn "malformed multi-byte sequence, search for '$replacement' in output file\n";

             return $replacement;
         };
         $octets = Encode::encode('UTF-8', $data, $handle_malformed);
    } else {
         $octets = $data;
    }

    open my $fh, ">", $path or return;

    $fh->print($octets) or return;
    $fh->close or return;

    return 1;
}

sub yaml_error {
    my ($filename, $error) = @_;

    my @lines = split /\n/, $error;
    pop @lines;
    return "$filename: " . join "\n", @lines;
}

sub lowercase($) {
    my ($str) = @_;

    return lc $str;
}

sub merge_data {
    my ($data, $overlay) = @_;

    # Return $overlay if it is of a different type than $data.
    my $equal_ref = sub {
        my ($x, $y) = @_;

        return if !ref $x;
        return if !ref $y;

        my $ref_x = reftype $x;
        my $ref_y = reftype $y;

        return $ref_x eq $ref_y;
    };

    return $overlay if !$equal_ref->($overlay, $data);
    return $overlay if 'ARRAY' eq reftype $overlay;

    my $merger;
    $merger = sub {
        my ($d, $o) = @_;

        foreach my $key (keys %$d) {
            if (exists $o->{$key}) {
                if (!$equal_ref->($d->{$key}, $o->{$key})) {
                    eval { $d->{$key} = $o->{$key}; };
                } elsif (UNIVERSAL::isa($d->{$key}, 'HASH')) {
                    $merger->($d->{$key}, $o->{$key});
                } else {
                    $d->{$key} = $o->{$key};
                }
            }
        }
        foreach my $key (keys %$o) {
            if (!exists $d->{$key}) {
                $d->{$key} = $o->{$key};
            }
        }
    };

    $merger->($data, $overlay);

    return $data;
}

sub interpolate($$) {
    my ($string, $data) = @_;

    $data ||= {};

    my $type = reftype $data;
    if ($type ne 'ARRAY' && $type ne 'HASH') {
        $type = 'HASH';
        $data = {};
    }

    my $result = '';
    while ($string =~ s/^([^\{]*)\{//) {
        $result .= $1;

        my ($remainder, @tokens) = tokenize $string, $type;

        # Syntax errors can be handled in different ways.
        # You can handle it gracefully and either leave
        # everything uninterpolated, or you could replace the
        # faulty string with the emtpy string or you can throw an
        # exception.  We just throw an exception.
        die "syntax error before: '$remainder'\n" if !@tokens;

        my $value = evaluate \@tokens, $data;
        $result .= $value if defined $value;
        $string = $remainder;
    }

    return $result . $string;
}

sub normalize_path($;$) {
    my ($dir, $trailing_slash) = @_;

    $dir =~ s{[\\/]+}{/}g;
    $dir =~ s{/$}{} unless $trailing_slash;

    return $dir;
}

sub strip_suffix($) {
    my ($filename) = @_;

    my @parts = split /\./, $filename;
    my @suffixes;

    while (@parts > 1) {
        last if $parts[-1] =~ /[^a-zA-Z0-9]/;
        unshift @suffixes, pop @parts
    }

    my $basename = join '.', @parts;

    return $basename, grep { /./ } @suffixes;
}