File Coverage

bin/glob

Criterion	Covered	Total	%
statement	66	102	64.7
branch	26	56	46.4
condition	0	21	0.0
subroutine	14	18	77.7
pod			n/a
total	106	197	53.8

#!/usr/bin/perl

=begin metadata

Name: glob
Description: find pathnames matching a pattern
Author: Marc Mengel, [e-mail]
Author: brian d foy, [e-mail]
License: perl

=end metadata

=cut

package PerlPowerTools::glob;

use strict;
use warnings;

our $VERSION = '2.1';

use constant EX_SUCCESS    => 0;
use constant EX_NO_MATCHES => 1;
use constant EX_FAILURE    => 1;
use constant EX_ERROR      => 2;
use constant IS_WINDOWS    => ( $^O eq 'MSWin32' );

use File::Basename;
use File::Glob qw(csh_glob GLOB_CSH);

__PACKAGE__->run(@ARGV) unless caller();

my %Unknown_users;
my $wildcards;
BEGIN { $wildcards = qr/[*?\[]/ }

sub run {
	my( $class, @args ) = @_;

	my( $code, $message ) = do {
		if( @args == 0 ) {
			( EX_ERROR, undef );
			}
		elsif( $class->globbrace(@args) == 0 ) {
			( EX_FAILURE, $class->missing_brace_message );
			}
		else {
			my $separator = "\n";
			if( $args[0] eq '-0' ) {
				shift @args;
				$separator = "\0";
				}

			my @ARGV_expanded = @args;
			if( IS_WINDOWS ) {
				@ARGV_expanded = map { expand_tilde($_) } @ARGV_expanded;
				}

			my @matches = csh_glob( "@ARGV_expanded", GLOB_CSH );

			if( @matches ) {
				$class->output_list( \@matches, $separator );
				( EX_SUCCESS );
				}
			elsif( () = keys %Unknown_users ) {
				( EX_NO_MATCHES, $class->no_match_message );
				}
			else {
				my( $message, $code ) = do {
					my $pattern = "@args";
					my $unknown = () = keys %Unknown_users;

					if( ! IS_WINDOWS && $pattern =~ /(?:\A|\s)~([\w-]+?)\b/ ) {
						getpwnam($1) ? undef : "Unknown user $1.";
						}
					elsif( $pattern =~ $wildcards ) {
						$class->no_match_message;
						}
					else { (undef, EX_FAILURE) }
					};
                $code = EX_NO_MATCHES unless defined $code;

				( $code, $message );
				}
			}
		};

	$class->exit( $code, $message );
	}

sub exit {
	my( $class, $code, $message ) = @_;

	print STDERR $message if defined $message;
	exit( defined $code ? $code : 0 );
	}

sub expand_tilde {
	return $_[0] unless IS_WINDOWS;
	return $_[0] unless $_[0] =~ $wildcards;
	local $_ = $_[0];

	my $home = my_home();
	my $dir  = dirname($home);
	$dir = '/Users' unless defined $dir;

	return $_ unless m/ \A ~ (\w+)? /x;
	my $user = $1;

	if( $user && ! $Unknown_users{$user}  ) {
		my $net_user = `net user "$user" 2>&1`;
		if( $net_user =~ /could not be found|The syntax of this command/ ) {
			print STDERR "Unknown user $user.\n";
			$Unknown_users{$user}++;
			return;
			}
		s/ \A ~ (\w+) /$dir\\$1/x
		}
	else {
		s/ \A ~ /$home/x;
		}

	return $_;
	}

# https://github.com/aatrens-juniper/OpenBSD-src/blob/master/bin/csh/glob.c
sub globbrace {
	my( $class, @args ) = @_;

	foreach my $s ( @args ) {
		my $start = index $s, '{';
		return 1 if $start == -1;

		my $counter = 0;
		STRING: for( my $i = 0; $i < length($s); $i++ ) {
			if( '[' eq substr($s, $i, 1) ) {
				SQUARE: for( $i++; $i <= length($s); $i++ ) {
					last SQUARE if ']' eq substr( $s, $i, 1 );
					return 0 if $i == length $s;
					}
				}
			elsif( '{' eq substr( $s, $i, 1 ) ) {
				$counter++
				}
			elsif( '}' eq substr( $s, $i, 1 ) ) {
				next if $counter == 0;
				$counter--
				}
			}

		return 0 if $counter != 0;
		}

	return 1;
	}


sub missing_brace_message { q(Missing '}'.) }

# Stolen from File::HomeDir::Windows;
sub my_home {
    # A lot of unix people and unix-derived tools rely on
    # the ability to overload HOME. We will support it too
    # so that they can replace raw HOME calls with File::HomeDir.
    if (exists $ENV{HOME} and defined $ENV{HOME} and length $ENV{HOME}) {
        return $ENV{HOME};
    	}

    # Do we have a user profile?
    if (exists $ENV{USERPROFILE} and $ENV{USERPROFILE}) {
        return $ENV{USERPROFILE};
    	}

    # Some Windows use something like $ENV{HOME}
    if (exists $ENV{HOMEDRIVE} and exists $ENV{HOMEPATH} and $ENV{HOMEDRIVE} and $ENV{HOMEPATH}) {
        return File::Spec->catpath($ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '',);
    	}

    return;
	}

sub no_match_message { 'glob: No match.' }

sub output_list {
	my( $class, $array, $separator ) = @_;
	$separator = "\n" unless defined $separator;

	print STDOUT join $separator, @$array;
	print "\n";
	}

=encoding utf8

=head1 NAME

glob - output pathnames matching a pattern

=head1 SYNOPSIS

On the command-line:

    glob 'eenie{meenie,mynie,moe}*.[ch]'

=head1 DESCRIPTION

When this program was originally created, *perl* did not have a builtin
C feature and would rely on the *csh* to do the work for it. With
Perl v5.6 in March 2000, the L module has done that work
without interacting with *csh*.

=head2 Pattern Matching Syntax for Filename Expansion

The expressions that are passed as arguments to B must adhere to
csh/tcsh pattern-matching syntax for wildcard filename expansion (also
known as I). Unquoted words containing an asterisk (C<*>),
question-mark (C), square-brackets (C<[...]>), or curly-braces (C<{...}>), or
beginning with a tilde (~), are expanded into an alphabetically sorted
list of filenames, as follows:

=over 5

=item C<*>

Match any (zero or more) characters.

=item C

Match any single character.

=item [...]

Match any single character in the given character class. The character
class is the enclosed list(s) or range(s). A list is a string of
characters. A range is two characters separated by a dash (-), and
includes all the characters in between the two characters given
(inclusive). If a dash (C<->) is intended to be part of the character
class it must be the first character given.

=item {str1,str2,...}

Expand the given "word-set" to each string (or filename-matching
pattern) in the comma-separated list. Unlike the pattern-matching
expressions above, the expansion of this construct is not sorted. For
instance, C<{foo,bar}> expands to C (not C). As
special cases, unmatched C<{> and C<}>, and the "empty set" (the string
{}) are treated as ordinary characters instead of pattern-matching
meta-characters. A backslash (C<\)> may be used to escape an opening or
closing curly brace, or the backslash character itself. Note that
word-sets I be nested!

=item C<~>

The home directory of the invoking user as indicated by the value of
the variable C<$HOME>.

=item ~username

The home directory of the user whose login name is 'username',
as indicated by the password entry for the named user.

=back

Only the patterns *, ? and [...] imply pattern matching; an error
results if no filename matches a pattern that contains them. When
a period or "dot" (.) is the first character in a filename or
pathname component, it must be matched explicitly. The filename
component separator character (e.g., / or slash) must also
be matched explicitly.

=head1 OPTIONS

When the first argument is B<-0> (a minus sign followed by the number
zero), then a NUL character ("\0") is used to separate the expanded
words and/or filenames when printing them to standard output.
Otherwise a newline is used as the word/filename output separator.

=head1 RETURNS

When B is invoked as a script from the command-line, the exit-status
returned will be 0 if any files were matched or word-sets were expanded;
1 if no files/word-sets were matched/expanded; and 2 if some other kind of
error occurred.

=head1 DIAGNOSTICS

If no filenames are matched and pattern-matching characters were used
(C<*>, C, or C<[...]>), then an error message of "No Match" is issued. If a
user's home directory is specified using tilde-expansion (e.g., C<~username>)
but the corresponding username or their home directory cannot be found,
then the error message "Unknown user: username" is issued.

=head1 COPYRIGHT

Copyright (c) 1997-2025 Marc Mengel. All rights reserved.

This library is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=head1 AUTHOR

Marc Mengel EFE

=head1 REVISIONS

=over 4

=item brian f foy EFE - v2.1 February 2025

Reimplement this as a thin layer over L. This
program was written before that was a core module, but had several
edge cases where it would crash.

=item Brad Appleton EFE - v1.2 March 1999

Modified to use qr// (and some other minor speedups), to explode
subexpressions in curly braces (a la csh -- rather than using just
plain alternation), and made callable as a standalone script.

=back

=cut