[pve-devel] [PATCH v1 pve-common 1/4] introduce PVE::Path
Max Carrara
m.carrara at proxmox.com
Thu Dec 19 19:31:40 CET 2024
The PVE::Path module concerns itself with file / directory path
operations, like getting the parent directory of a path, extracting
the file name of a path, splitting a path into its individual
components, joining path components together, comparing paths, and so
on.
This module is added here in order to address the shortcomings of the
Perl core modules (such as lacking a lot the aforementioned
functionalities) without relying on some kind of object-based
abstraction.
PVE::Path strictly only contains functions that manipulate file paths
without meddling with the filesystem. The reasoning here is to be able
to just import any function when its necessary without having to
change the surrounding code in order to adapt to some kind of
abstraction.
The other motivation for this module is that path manipulation
operations have been getting more and more common recently, especially
in regards to storage.
Signed-off-by: Max Carrara <m.carrara at proxmox.com>
---
src/Makefile | 1 +
src/PVE/Path.pm | 956 ++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 957 insertions(+)
create mode 100644 src/PVE/Path.pm
diff --git a/src/Makefile b/src/Makefile
index 2d8bdc4..25bc490 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -23,6 +23,7 @@ LIB_SOURCES = \
LDAP.pm \
Network.pm \
OTP.pm \
+ Path.pm \
PBSClient.pm \
PTY.pm \
ProcFSTools.pm \
diff --git a/src/PVE/Path.pm b/src/PVE/Path.pm
new file mode 100644
index 0000000..d411027
--- /dev/null
+++ b/src/PVE/Path.pm
@@ -0,0 +1,956 @@
+=head1 NAME
+
+C<PVE::Path> - Utilities related to handling file and directory paths
+
+=head1 DESCRIPTION
+
+This module provides functions concerned with file and directory path
+manipulation.
+
+None of the functions provided alter the filesystem in any way.
+
+The reason for this module's existence is to address a couple shortcomings:
+
+=over
+
+=item 1. The Perl core modules lack most of what is required for manipulating
+paths, for example getting the parent directory of a path, extracting the
+prefix of a file name (the "stem"), extracting the suffixes of a file name (the
+"endings" or "extensions"), checking whether two paths are the same, and so on.
+
+=item 2. If the Perl core modules provide something in that regard, it's usually
+provided in a not very ergonomic manner (L<C<File::Basename>>).
+
+=item 3. Additionally, the path utilities of the core modules are scattered
+across multiple modules, making them hard to discover.
+
+=item 4. Third-party libraries on CPAN mostly provide objects representing
+paths. Using any of these would require fundamental changes on how file paths
+are handled throughout our code, for almost no benefit.
+
+=back
+
+C<L<PVE::Path>> instead does without objects and strictly provides functions
+for path manipulation only. Any operation that is needed can simply be
+performed ad hoc by importing the corresponding function and doesn't require
+the surrounding code to conform to an abstraction like a path object.
+
+Additionally, some of the core modules' functionality is re-exported or
+re-implemented for ergonomic or logical purposes. The goal is to provide
+functions that don't come with any surprises and just behave like one assumes
+they would.
+
+This module takes inspiration from Rust's C<std::path> and Python's C<pathlib>,
+which are more modern path manipulation libraries.
+
+=head1 LIMITATIONS
+
+This module is limited to manipulating Unix-like / Linux file paths.
+
+=cut
+
+package PVE::Path;
+
+use strict;
+use warnings;
+
+use Carp qw(carp croak confess);
+use File::Spec ();
+use List::Util qw(any zip_shortest zip_longest);
+
+use Exporter qw(import);
+
+our @EXPORT_OK = qw(
+ path_is_absolute
+ path_is_relative
+
+ path_components
+ path_join
+
+ path_normalize
+
+ path_parent
+ path_push
+ path_pop
+
+ path_file_name
+ path_with_file_name
+
+ path_file_prefix
+ path_with_file_prefix
+
+ path_file_suffixes
+ path_with_file_suffixes
+
+ path_file_suffix
+ path_with_file_suffix
+
+ path_file_parts
+
+ path_starts_with
+ path_ends_with
+ path_equals
+);
+
+=head2 FUNCTIONS
+
+=cut
+
+=head3 path_is_absolute($path)
+
+Checks whether the given C<$path> is absolute (starts with a C</>).
+
+Throws an exception if C<$path> is C<undef> or if called in list context.
+
+=cut
+
+sub path_is_absolute : prototype($) {
+ my ($path) = @_;
+
+ croak "subroutine called in list context" if wantarray;
+ croak "\$path is undef" if !defined($path);
+
+ return $path =~ m#^/#;
+}
+
+=head3 path_is_relative($path)
+
+Checks whether the given C<$path> is relative (doesn't start with a C</>).
+The opposite of C<L<< path_is_absolute()|/"path_is_absolute($path)" >>>.
+
+Throws an exception if C<$path> is C<undef> or if called in list context.
+
+=cut
+
+sub path_is_relative : prototype($) {
+ my ($path) = @_;
+
+ croak "subroutine called in list context" if wantarray;
+ croak "\$path is undef" if !defined($path);
+
+ return $path !~ m#^/#;
+}
+
+=head3 path_components($path)
+
+Returns a list of the given C<$path>'s individual components.
+
+In scalar context, returns a reference to a list.
+
+The C<$path> is normalized a little during parsing:
+
+=over
+
+=item Repeated occurrences of C</> are removed, so C<foo/bar> and C<foo//bar>
+both have C<foo> and C<bar> as components.
+
+=item Trailing slashes C</> are removed.
+
+=item Occurrences of C<.> are normalized away, except the first C<.> at
+beginning of a path. This means that C<foo/bar>, C<foo/./bar>, C<foo/bar/.>,
+C<foo/././bar/./.>, etc. all have C<foo> and C<bar> as components, while
+C<./foo/bar>, C<./././foo/bar>, C<./foo/./bar/.> have C<.>, C<foo> and C<bar>
+as components.
+
+=back
+
+No other normalization is performed to account for the possibility of symlinks
+existing. This means that C<foo/baz> and C<foo/bar/../baz> are distinct (because
+C<bar> could be a symlink and thus C<foo> isn't its parent).
+
+Throws an exception if C<$path> is C<undef>.
+
+=cut
+
+sub path_components : prototype($) {
+ my ($path) = @_;
+
+ croak "\$path is undef" if !defined($path);
+
+ my $is_abs = path_is_absolute($path);
+ my $has_cur_dir = $path =~ m#^\.$|^\./#;
+
+ my @components = split('/', $path);
+ my @normalized_components = ();
+
+ for my $component (@components) {
+ next if $component eq '' || $component eq '.';
+
+ push(@normalized_components, $component);
+ }
+
+ unshift(@normalized_components, '/') if $is_abs;
+ unshift(@normalized_components, '.') if $has_cur_dir;
+
+ return @normalized_components if wantarray;
+ return \@normalized_components;
+}
+
+
+=head3 path_join(@paths)
+
+Joins multiple paths together. All kinds of paths are supported.
+
+Does not perform any C<L<< normalization|/"path_normalize($path)" >>>.
+
+Throws an exception if any of the passed C<@paths> is C<undef>.
+
+=cut
+
+sub path_join : prototype(@) {
+ my (@paths) = @_;
+
+ if (!scalar(@paths)) {
+ return '';
+ }
+
+ croak "one of the provided paths is undef" if any { !defined($_) } @paths;
+
+ # Find the last occurrence of a root directory and start conjoining the
+ # components from there onwards
+ my $index = scalar(@paths) - 1;
+ while ($index > 0) {
+ last if $paths[$index] =~ m#^/#;
+ $index--;
+ }
+
+ @paths = @paths[$index .. (scalar(@paths) - 1)];
+
+ my $resulting_path = shift @paths;
+
+ for my $path (@paths) {
+ $resulting_path = path_push($resulting_path, $path);
+ }
+
+ return $resulting_path;
+}
+
+=head3 path_normalize($path)
+
+Wrapper for L<C<File::Spec/canonpath>>. Performs a logical cleanup of the given
+C<$path>.
+
+This removes unnecessary components of a path that can be safely
+removed, such as C<.>, trailing C</> or repeated occurrences of C</>.
+
+For example, C<foo/./bar/baz/.> and C<foo////bar//baz//> will both become
+C<foo/bar/baz>.
+
+B<Note:> This will I<not> remove components referencing the parent directory,
+i.e. C<..>. For example, C<foo/bar/../baz> and C<foo/bar/baz/..> will therefore
+remain as they are. However, the parent directory of C</> is C</>, so
+C</../../foo> will be normalized to C</foo>.
+
+Throws an exception if C<$path> is C<undef> or the call to C<canonpath> failed.
+
+=cut
+
+sub path_normalize : prototype($) {
+ my ($path) = @_;
+
+ croak "\$path is undef" if !defined($path);
+
+ my $cleaned_path = eval {
+ File::Spec->canonpath($path);
+ };
+
+ croak "failed to clean up path: $@" if $@;
+
+ return $cleaned_path;
+}
+
+=head3 path_parent($path)
+
+Returns the given C<$path> without its final component, if there is one.
+
+Trailing and repeated occurrences of C</> and C<.> are normalized on the fly
+when needed. This means that e.g. C<foo////bar///.//> becomes C<foo>, but
+C<foo/.//bar//./baz> becomes C<foo/.//bar>.
+
+This function's behaviour is almost identical to Rust's
+L<< Path::parent|https://doc.rust-lang.org/std/path/struct.Path.html#method.parent >>,
+with a few adaptations made wherever Perl treats things differently:
+
+=over
+
+=item * C</foo/bar> becomes C</foo>, C<foo/bar> becomes C<foo>.
+
+=item * C</foo> becomes C</>.
+
+=item * C<foo/bar/..> becomes C<foo/bar>.
+
+=item * C<foo/../bar> becomes C<foo/..>.
+
+=item * C<foo> is interpreted as C<./foo> and becomes C<.>. This is because Perl's
+C<L<File::Spec/canonpath>> interprets C<./foo> and C<foo> as the same thing.
+
+=item * C</> and an I<empty string> result in C<undef> being returned.
+
+=item * C<.> results in an empty string.
+
+=back
+
+Will raise an exception if C<$path> is C<undef>.
+
+=cut
+
+sub path_parent : prototype($) {
+ my ($path) = @_;
+
+ croak "\$path is undef" if !defined($path);
+
+ if ($path eq '') {
+ return;
+ }
+
+ # A limit of -1 retains empty components at the end
+ my @components = split('/', $path, -1);
+
+ # Trim off needless extra components until actual final component is encountered, e.g.
+ # foo////bar////baz//// -> foo////bar////baz
+ # /// -> /
+ # ././//.///./ -> .
+ while (scalar(@components) > 1 && ($components[-1] eq '' || $components[-1] eq '.')) {
+ pop(@components);
+ }
+
+ my $final_component = pop(@components);
+
+ if (defined($final_component)) {
+ # We had a root dir with needless extra components, e.g. "//" or "////" or "//.///./" etc.
+ if ($final_component eq '') {
+ return;
+ }
+
+ # We had a current dir reference with needless extra components, e.g.
+ # "././" or ".///////" or "./././//./././//" etc.
+ if ($final_component eq '.') {
+ return "";
+ }
+ } else {
+ confess "\$final_component wasn't undef";
+ }
+
+ # Trim off needless extra components until actual parent component is encountered, like above
+ while (scalar(@components) > 1 && ($components[-1] eq '' || $components[-1] eq '.')) {
+ pop(@components);
+ }
+
+ # Handle lone root dir (@components with only one empty string)
+ if (scalar(@components) == 1 && $components[0] eq '') {
+ return '/';
+ }
+
+ return join('/', @components);
+}
+
+=head3 path_push($path, $other)
+
+Extends C<$path> with C<$other>, returning a new path.
+
+If C<$other> is absolute, it will be returned instead.
+
+Throws an exception if any of the arguments is C<undef>.
+
+=cut
+
+sub path_push : prototype($$) {
+ my ($path, $other) = @_;
+
+ croak "\$path is undef" if !defined($path);
+ croak "\$other is undef" if !defined($other);
+
+ return $other if path_is_absolute($other);
+ return $path if $other eq '';
+
+ my $need_sep = $path ne '' && $path !~ m#/$#;
+
+ $path .= "/" if $need_sep;
+ $path .= $other;
+
+ return $path;
+}
+
+=head3 path_pop($path)
+
+Alias for C<L<< path_parent()|/"path_parent($path)" >>>.
+
+=cut
+
+sub path_pop : prototype($) {
+ my ($path) = @_;
+ return path_parent($path);
+}
+
+=head3 path_file_name($path)
+
+Returns the last component of the given C<$path>, if it is a legal file name,
+or C<undef> otherwise.
+
+If C<$path> is an empty string, C</>, C<.> or ends with a C<..> component,
+there is no valid file name.
+
+B<Note:> This does not check whether the given C<$path> actually points to a
+file or a directory etc.
+
+Throws an exception if C<$path> is C<undef>.
+
+=cut
+
+sub path_file_name : prototype($) {
+ my ($path) = @_;
+
+ croak "\$path is undef" if !defined($path);
+
+ my @components = path_components($path);
+
+ if (!scalar(@components)) {
+ return;
+ }
+
+ if (
+ scalar(@components) == 1
+ && ($components[0] eq '/' || $components[0] eq '.')
+ ) {
+ return;
+ }
+
+ if ($components[-1] eq '..') {
+ return;
+ }
+
+ return $components[-1];
+}
+
+=head3 path_with_file_name($path, $file_name)
+
+Returns C<$path> with C<$file_name> as the new last component.
+
+This is essentially like calling C<L<< path_parent()|/"path_parent($path)" >>>
+and using C<L<< path_push()|/"path_push($path, $other)" >>> to append the new
+file name, but handles a few extra cases:
+
+=over
+
+=item * If C<$path> is C</>, appends C<$file_name>.
+
+=item * If C<$path> is an empty string, appends C<$file_name>.
+
+=item * If C<$path> ends with a parent directory reference (C<..>), replaces it
+with C<$file_name>.
+
+=back
+
+Throws an exception if any of the arguments is C<undef> or if C<$file_name>
+contains a path separator (C</>).
+
+=cut
+
+sub path_with_file_name : prototype($$) {
+ my ($path, $file_name) = @_;
+
+ croak "\$path is undef" if !defined($path);
+ croak "\$file_name is undef" if !defined($file_name);
+ croak "\$file_name contains a path separator: $file_name" if $file_name =~ m|/|;
+
+ my $parent = path_parent($path);
+
+ # undef means that $path was either "" or "/", so we can just append to it
+ return ($path . $file_name) if !defined($parent);
+
+ return path_push($parent, $file_name);
+}
+
+my sub _path_file_prefix : prototype($) {
+ my ($file_name) = @_;
+
+ confess "\$file_name is undef" if !defined($file_name);
+
+ $file_name =~ s|^(\.*[^\.]*)||;
+ my $prefix = $1;
+
+ # sanity check
+ confess "\$prefix not matched" if !defined($prefix);
+
+ return ($prefix, $file_name);
+}
+
+=head3 path_file_prefix($path)
+
+Returns the prefix of the file name of the given C<$path>. If the C<$path> does
+not have a valid file name and thus no prefix, C<undef> is returned instead.
+
+The prefix of a file name is the part before any extensions (suffixes).
+
+ my $prefix = path_file_prefix("/etc/resolv.conf");
+ # resolv
+
+ my $prefix = path_file_prefix("/tmp/archive.tar.zst");
+ # archive
+
+Throws an exception if C<$path> is C<undef>.
+
+=cut
+
+sub path_file_prefix : prototype($) {
+ my ($path) = @_;
+
+ croak "\$path is undef" if !defined($path);
+
+ my $file_name = path_file_name($path);
+ return undef if !defined($file_name);
+
+ my ($prefix, undef) = _path_file_prefix($file_name);
+ return $prefix;
+}
+
+=head3 path_with_file_prefix($path, $prefix)
+
+Returns C<$path> with a new C<$prefix>. This is similar to
+C<L<< path_with_file_name()|/"path_with_file_name($path, $file_name)" >>>,
+except that the file prefix is replaced or appended.
+
+If C<$path> does not have a file name or if C<$prefix> is an empty string,
+C<undef> is returned.
+
+ my $new_path = path_with_file_prefix("/tmp/archive.tar.zst", "backup");
+ # /tmp/backup.tar.zst
+
+ my $new_path = path_with_file_prefix("/etc/pve", "ceph");
+ # /etc/ceph
+
+Throws an exception if any of the arguments is C<undef>, or if C<$prefix>
+contains a path separator (C</>), ends with C<.>, or is an empty string.
+
+=cut
+
+sub path_with_file_prefix : prototype($$) {
+ my ($path, $prefix) = @_;
+
+ croak "\$path is undef" if !defined($path);
+ croak "\$prefix is undef" if !defined($prefix);
+ croak "\$prefix contains a path separator" if $prefix =~ m|/|;
+ croak "\$prefix ends with a dot" if $prefix =~ m|\.$|;
+
+ return undef if $prefix eq '';
+ return undef if !defined(path_file_name($path));
+
+ return $path if $prefix eq '';
+
+ my $parent = path_parent($path);
+
+ # sanity check -- should not happen because we checked for file name,
+ # and the existence of a file name implies there's a parent
+ confess "parent of \$path is undef" if !defined($parent);
+
+ my @suffixes = path_file_suffixes($path);
+
+ my $file_name = join(".", $prefix, @suffixes);
+
+ return path_push($parent, $file_name);
+}
+
+my sub _path_file_suffixes : prototype($) {
+ my ($file_name_no_prefix) = @_;
+
+ confess "\$file_name_no_prefix is undef" if !defined($file_name_no_prefix);
+
+ # Suffixes are extracted "manually" because join()ing the result of split()
+ # results in a different file name than the original. Let's say you have a
+ # file named "foo.bar.". The correct suffixes would be ("bar", "").
+ # With split, you get the following:
+ # split(/\./, ".bar.") --> ("", "bar") --> join()ed to "foo..bar"
+ # split(/\./, ".bar.", -1) --> ("", "bar", "") --> join()ed to "foo..bar."
+ my @suffixes = ();
+ while ($file_name_no_prefix =~ s|^(\.[^\.]*)||) {
+ my $suffix = $1;
+ $suffix =~ s|^\.||;
+ push(@suffixes, $suffix);
+ }
+
+ return @suffixes;
+}
+
+=head3 path_file_suffixes($path)
+
+Returns the suffixes of the C<$path>'s file name as a list. If the C<$path> does
+not have a valid file name, an empty list is returned instead.
+
+In scalar context, returns a reference to a list.
+
+The suffixes of a path are essentially the file name's extensions, the parts
+that come after the L<< prefix|/"path_file_prefix($path)" >>.
+
+ my @suffixes = path_file_suffixes("/etc/resolv.conf");
+ # ("conf")
+
+ my $suffixes = path_file_prefix("/tmp/archive.tar.zst");
+ # ["tar", "zst"]
+
+Throws an exception if C<$path> is C<undef>.
+
+=cut
+
+sub path_file_suffixes : prototype($) {
+ my ($path) = @_;
+
+ croak "\$path is undef" if !defined($path);
+
+ my $file_name = path_file_name($path);
+ if (!defined($file_name)) {
+ return wantarray ? () : [];
+ }
+
+ (undef, $file_name) = _path_file_prefix($file_name);
+
+ my @suffixes = _path_file_suffixes($file_name);
+
+ return wantarray ? @suffixes : \@suffixes;
+}
+
+=head3 path_with_file_suffixes($path, @suffixes)
+
+Returns C<$path> with new C<@suffixes>. This is similar to
+C<L<< path_with_file_name()|/"path_with_file_name($path, $file_name)" >>>,
+except that the suffixes of the file name are replaced.
+
+If the C<$path> does not have a file name, C<undef> is returned.
+
+ my $new_path = path_with_file_suffixes("/tmp/archive.tar.zst", "pxar", "gz");
+ # /tmp/archive.pxar.gz
+
+ my $new_path = path_with_file_suffixes("/tmp/archive.tar.zst", "gz");
+ # /tmp/archive.gz
+
+If the file name has no suffixes, the C<@suffixes> are appended instead:
+
+ my $new_path = path_with_file_suffixes("/etc/resolv", "conf");
+ # /etc/resolv.conf
+
+ my $new_path = path_with_file_suffixes("/etc/resolv", "conf", "zst");
+ # /etc/resolv.conf.zst
+
+If there are no C<@suffixes> provided, the file name's suffixes will
+be removed (if there are any):
+
+ my $new_path = path_with_file_suffixes("/tmp/archive.tar.zst");
+ # /tmp/archive
+
+Note that an empty string is still a valid suffix (an "empty" file ending):
+
+ my $new_path = path_with_file_suffixes("/tmp/archive.tar.zst", "", "", "", "zst");
+ # /tmp/archive....zst
+
+Throws an exception if C<$path> or any of the C<@suffixes> is C<undef>, or
+if any suffix contains a path separator (C</>) or a C<.>.
+
+=cut
+
+sub path_with_file_suffixes : prototype($@) {
+ my ($path, @suffixes) = @_;
+
+ croak "\$path is undef" if !defined($path);
+ croak "one of the provided suffixes is undef"
+ if any { !defined($_) } @suffixes;
+ croak "one of the provided suffixes contains a path separator"
+ if any { $_ =~ m|/| } @suffixes;
+ croak "one of the provided suffixes contains a dot"
+ if any { $_ =~ m|\.| } @suffixes;
+
+ return undef if !defined(path_file_name($path));
+
+ my $parent = path_parent($path);
+
+ # sanity check -- should not happen because we checked for file name,
+ # and the existence of a file name implies there's a parent
+ confess "parent of \$path is undef" if !defined($parent);
+
+ # Don't modify $path if there are no suffixes to be removed
+ my @existing_suffixes = path_file_suffixes($path);
+ return $path if !scalar(@suffixes) && !scalar(@existing_suffixes);
+
+ my $prefix = path_file_prefix($path);
+
+ # sanity check
+ confess "\$prefix is undef" if !defined($prefix);
+
+ my $file_name = join(".", $prefix, @suffixes);
+
+ return path_push($parent, $file_name);
+}
+
+=head3 path_file_suffix($path)
+
+Returns the suffix of the C<$path>'s file name. If the C<$path> does not have a
+valid file name or if the file name has no suffix, C<undef> is returned
+instead.
+
+The suffix of a file name is essentially its extension, e.g.
+C</etc/resolv.conf> has the suffix C<conf>. If there are multiple suffixes,
+only the last will be returned; e.g. C</tmp/archive.tar.gz> has the suffix C<gz>.
+
+B<Note:> Files like e.g. C</tmp/foo.> have an empty string as suffix.
+
+For getting all suffixes of a path, see C<L<< path_file_suffixes()|/"path_file_suffixes($path)" >>>.
+
+Throws an exception if C<$path> is C<undef>.
+
+=cut
+
+sub path_file_suffix : prototype($) {
+ my ($path) = @_;
+
+ croak "\$path is undef" if !defined($path);
+
+ my $file_name = path_file_name($path);
+ return undef if !defined($file_name);
+
+ (undef, $file_name) = _path_file_prefix($file_name);
+
+ my @suffixes = _path_file_suffixes($file_name);
+
+ return pop(@suffixes);
+}
+
+=head3 path_with_file_suffix($path, $suffix)
+
+Returns C<$path> with a new C<$suffix>. This is similar to
+C<L<< path_with_file_suffixes()|/"path_with_file_suffixes($path, @suffixes)" >>>,
+except that only the last suffix of the file name is replaced.
+
+If the C<$path> does not have a file name, C<undef> is returned.
+
+ my $new_path = path_with_file_suffix("/tmp/archive.tar.zst", "gz");
+ # /tmp/archive.tar.gz
+
+If the file name has no suffixes, the C<$suffix> is appended instead:
+
+ my $new_path = path_with_file_suffix("/etc/resolv", "conf");
+ # /etc/resolv.conf
+
+If C<$suffix> is C<undef>, the file name's (last) suffix will be removed (if
+there is one):
+
+ my $new_path = path_with_file_suffix("/tmp/archive.tar.zst", undef);
+ # /tmp/archive.tar
+
+ my $new_path = path_with_file_suffix("/etc/resolv", undef);
+ # /etc/resolv
+
+Note that an empty string is still a valid suffix (an "empty" file ending):
+
+ my $new_path = path_with_file_suffix("/tmp/archive.tar.zst", "");
+ # /tmp/archive.tar.
+
+ my $new_path = path_with_file_suffix("/etc/resolv", "");
+ # /etc/resolv.
+
+Throws an exception if any of the arguments is C<undef>, or if C<$suffix>
+contains a path separator (C</>) or a C<.>.
+
+=cut
+
+sub path_with_file_suffix : prototype($$) {
+ my ($path, $suffix) = @_;
+
+ croak "\$path is undef" if !defined($path);
+
+ if (defined($suffix)) {
+ croak "\$suffix contains a path separator" if $suffix =~ m|/|;
+ croak "\$suffix contains a dot" if $suffix =~ m|\.|;
+ }
+
+ return undef if !defined(path_file_name($path));
+
+ my $parent = path_parent($path);
+
+ # sanity check -- should not happen because we checked for file name,
+ # and the existence of a file name implies there's a parent
+ confess "parent of \$path is undef" if !defined($parent);
+
+ my @suffixes = path_file_suffixes($path);
+
+ # Don't modify $path if there is no suffix to be removed
+ return $path if !scalar(@suffixes) && !defined($suffix);
+
+ pop(@suffixes);
+ push(@suffixes, $suffix) if defined($suffix);
+
+ my $prefix = path_file_prefix($path);
+
+ # sanity check
+ confess "\$prefix is undef" if !defined($prefix);
+
+ my $file_name = join(".", $prefix, @suffixes);
+
+ return path_push($parent, $file_name);
+}
+
+=head3 path_file_parts($path)
+
+Returns the parts that constitute the file name (prefix and suffixes) of a
+C<$path> as a list. If the C<$path> does not have a valid file name, an empty
+list is returned instead.
+
+In scalar context, returns a reference to a list.
+
+These parts are split in such a way that allows them to be C<join>ed together,
+resulting in the original file name of the given C<$path> again.
+
+ my $file_parts = path_file_parts("/etc/pve/firewall/cluster.fw");
+ # ("cluster", "fw")
+ my $file_name = join(".", $file_parts->@*);
+
+ my @file_parts = path_file_parts("/tmp/archive.tar.gz");
+ # ("archive", "tar", "gz")
+ my $file_name = join(".", @file_parts);
+
+Throws an exception if C<$path> is C<undef>.
+
+=cut
+
+sub path_file_parts : prototype($) {
+ my ($path) = @_;
+
+ croak "\$path is undef" if !defined($path);
+
+ my $file_name = path_file_name($path);
+ if (!defined($file_name)) {
+ return wantarray ? () : [];
+ }
+
+ my $prefix;
+ ($prefix, $file_name) = _path_file_prefix($file_name);
+
+ my @suffixes = _path_file_suffixes($file_name);
+
+ my @file_parts = ($prefix, @suffixes);
+
+ return wantarray ? @file_parts : \@file_parts;
+}
+
+=head3 path_starts_with($path, $other_path)
+
+Checks whether a C<$path> starts with the components of C<$other_path>.
+
+ my $starts_with = path_starts_with("/etc/pve/firewall/cluster.fw", "/etc/pve");
+ # 1
+
+Throws an exception if any of the arguments is C<undef>.
+
+=cut
+
+sub path_starts_with : prototype($$) {
+ my ($path, $other_path) = @_;
+
+ croak "\$path is undef" if !defined($path);
+ croak "\$other_path if undef" if !defined($other_path);
+
+ # Nothing starts with nothing
+ return 1 if ($path eq '' && $other_path eq '');
+
+ # Nothing cannot start with something
+ # Something cannot start with nothing
+ return if ($path eq '' || $other_path eq '');
+
+ my @components = path_components($path);
+ my @other_components = path_components($other_path);
+
+ my @pairs = zip_shortest(\@components, \@other_components);
+
+ # for my ($comp, $other_comp) (@pairs) is experimental
+ for my $pair (@pairs) {
+ my ($comp, $other_comp) = $pair->@*;
+
+ if ($comp ne $other_comp) {
+ return;
+ }
+ }
+
+ return 1;
+}
+
+=head3 path_ends_with($path, $other_path)
+
+Checks whether a C<$path> ends with the components of C<$other_path>.
+
+ my $ends_with = path_ends_with("/etc/pve/firewall/cluster.fw", "firewall/cluster.fw");
+ # 1
+
+Throws an exception if any of the arguments is C<undef>.
+
+=cut
+
+sub path_ends_with : prototype($$) {
+ my ($path, $other_path) = @_;
+
+ croak "\$path is undef" if !defined($path);
+ croak "\$other_path if undef" if !defined($other_path);
+
+ # Nothing ends with nothing
+ return 1 if ($path eq '' && $other_path eq '');
+
+ # Nothing cannot end with something
+ # Something cannot end with nothing
+ return if ($path eq '' || $other_path eq '');
+
+ my @components_rev = reverse(path_components($path));
+ my @other_components_rev = reverse(path_components($other_path));
+
+ my @pairs_rev = zip_shortest(\@components_rev, \@other_components_rev);
+
+ # for my ($comp, $other_comp) (@pairs_rev) is experimental
+ for my $pair (@pairs_rev) {
+ my ($comp, $other_comp) = $pair->@*;
+
+ if ($comp ne $other_comp) {
+ return;
+ }
+ }
+
+ return 1;
+}
+
+=head3 path_equals($path, $other_path)
+
+Checks whether C<$path> equals C<$other_path>. The paths are compared
+by their components, meaning that it's not necessary to
+L<< normalize|/"path_normalize($path)" >> them beforehand.
+
+=cut
+
+sub path_equals : prototype($$) {
+ my ($path, $other_path) = @_;
+
+ croak "\$path is undef" if !defined($path);
+ croak "\$other_path if undef" if !defined($other_path);
+
+ # Nothing is nothing
+ return 1 if ($path eq '' && $other_path eq '');
+
+ # Nothing is not something
+ # Something is not nothing
+ return if ($path eq '' || $other_path eq '');
+
+ my @components = path_components($path);
+ my @other_components = path_components($other_path);
+
+ return if scalar(@components) != scalar(@other_components);
+
+ my @pairs = zip_longest(\@components, \@other_components);
+
+ # for my ($comp, $other_comp) (@pairs_rev) is experimental
+ for my $pair (@pairs) {
+ my ($comp, $other_comp) = $pair->@*;
+
+ return if !defined($comp) || !defined($other_comp);
+
+ if ($comp ne $other_comp) {
+ return;
+ }
+ }
+
+ return 1;
+}
+
+1;
--
2.39.5
More information about the pve-devel
mailing list