view release on metacpan or  search on metacpan

lib/FP/Path.pm  view on Meta::CPAN

use FP::Show;
use FP::Equal;
use FP::Carp;

sub perhaps_segment_error {
    @_ == 1 or fp_croak_arity 1;
    my ($segment) = @_;
    return "segments must be strings" unless is_string $segment;
    return "segments cannot be the empty string" unless length $segment;
    return "segment contains slash: " . show($segment) if $segment =~ m{/};
    ()
}

sub is_segment {
    @_ == 1 or fp_croak_arity 1;
    not perhaps_segment_error $_[0]
}

sub check_segment {
    @_ == 1 or fp_croak_arity 1;
    if (my ($e) = perhaps_segment_error $_[0]) {
        die $e
    }
}

# Toggle typing, off for speed (checking FP::List costs O(length);
# better use FP::StrictList if really interested in strict typing!)
sub use_costly_typing {
    @_ == 0 or fp_croak_arity 0;
    0
}
our $use_costly_typing = use_costly_typing;    # for access from FP::Path::t

sub typed {
    @_ == 2 or fp_croak_arity 2;
    my ($pred, $name) = @_;
    if (use_costly_typing) { [$pred, $name] }
    else {
        $name
    }
}

use FP::Struct [
    typed(list_of(\&is_segment), 'rsegments'),     # reversed list
    typed(\&is_boolean,          'has_endslash')
    ,    # whether the path is forcibly specifying a
         # dir by using a slash at the end (forcing a
         # dir by ending in "." isn't setting this
         # flag)
    typed(\&is_boolean, 'is_absolute'),    # bool
    ],
    'FP::Struct::Show',
    'FP::Abstract::Equal',
    'FP::Abstract::Pure';

*import = constructorexporter new_from_string => "path";

sub new_from_string {
    @_ == 2 or fp_croak_arity 2;
    my ($class, $str) = @_;
    my @p = split m{/+}, $str;
    shift @p if (@p and $p[0] eq "");
    $class->new(
        array_to_list_reverse(\@p),
        scalar $str =~ m{/$}s,
        scalar $str =~ m{^/}s
    )
}

sub FP_Equal_equal {
    @_ == 2 or fp_croak_arity 2;
    my ($a, $b) = @_;

    # no need to compare is_absolute, since it is being distinguished
    # anyway? Or better be safe than sorry?
    (           (!!$a->is_absolute eq !!$b->is_absolute)
            and (!!$a->has_endslash eq !!$b->has_endslash)
            and equal($a->rsegments, $b->rsegments))
}

sub segments {
    my $s = shift;
    $s->rsegments->reverse
}

sub string {
    my $s  = shift;
    my $rs = $s->rsegments;

    # check that no invalid segments have creeped in (by way of using
    # the "lowlevel" accessors like segments_set, or the new or new_
    # constructors directly; adding a type check to the segments field
    # would solve this, but is less efficient as it would have to walk
    # the list on every change instead of only stringification):
    $rs->for_each(\&check_segment);

    # force "." for empty relative paths:
    my $rs1 = is_null($rs) && not($s->is_absolute) ? list(".") : $rs;

    # add end slash
    my $ss = ($s->has_endslash ? $rs1->cons("") : $rs1)->reverse;

    # add start slash
    ($s->is_absolute ? $ss->cons("") : $ss)->strings_join("/")
}

# remove "." entries: (leave ".." in, because these cannot be resolved
# without reading the file system or knowing the usage)
sub clean_dot {
    my $s    = shift;
    my $rseg = $s->rsegments;
    $s->rsegments_set($rseg->filter(sub { not($_[0] eq ".") }))
        ->has_endslash_set(

        # set forced dir flag if the last segment was a ".", even
        # if previously it didn't end in "/"
        $$s{has_endslash} or do {
            if (is_null $rseg) {
                0
            } else {
                $rseg->first eq "."