view release on metacpan or  search on metacpan

KGlob.pm  view on Meta::CPAN

require File::KGlob2RE;

# &glob( "pat" [, ...] ) - Expands Unix file glob(s) into the list of
# matching Unix files.  The following contructs are supported:
#   \x		matches x
#   [abc]	matches the single character "a", "b", or "c"
#   [a-c]	same as above
#   [^a-c]	matches any single character but "a", "b", "c", "/", or "\0"
#   ?		matches any single character except "/" and "\0"
#   *		matches zero or more characters not including "/" and "\0"
#   {X,Y,Z}	matches one of the patterns X, Y, or Z

%GlobContext= ();

sub glob {
  my( $pkg, $file, $line )= caller;
    if(  ! $GlobContext{$file,$line}  ) {
      my( @list )= &kglob( @_ );
	@list= sort( @list )   if  $Sort;
	$GlobContext{$file,$line}= \@list;
    }
    if(  wantarray  ) {
      my( @return )= @{$GlobContext{$file,$line}};
	delete $GlobContext{$file,$line};
	@return;
    } else {
      my( $return )= shift( @{$GlobContext{$file,$line}} );
	delete $GlobContext{$file,$line}   if ! defined($return);
	$return;
    }
}

# &kglob() always returns an array of matches; the complexity of the
# algorythm would require a great deal of saved context to allow each
# match to be returned separately like is possible with &fglob().
#   The array of values is not necessarilly sorted (that is easy enough
# to do if you want it so we won't waste the time to do it in case you
# don't want to).
#   kglob may suprise you in the following ways:
#	- {a,b} expands to ("a","b") even if files "a" and/or "b" do not exist
#	- [^a-z] is supported (any character except a through z, /, and \0)
#	- a leading dot (.) in any component of the path must be matched
#	  explicitly (with a dot, not with [^a-z], nor [.x], etc.)
#	- {.,x}* matches .* (as well as x*)
#	- setting $File::KGlob::Safe to a true value prevents "." and ".."
#	  in any component of the path from matching except exactly (by the
#	  pattern "." or "..")
#	- \x is supported (expands to just "x")
#	- % is not support (just matches "%") but File::KGlob2RE supports it
#	- ~user and ~/ are supported as is ~{user1,user2} etc.

sub kglob {
  my( @alts, @return, $user, $home );
    foreach(  @_  ) {
	# If unquoted "{" in string, generate all possible combinations: #}
	@alts=  m#(^|[^\\])(\\\\)*\{#  ?  &unbrac( $_ )  :  ( $_ );	 #}
	foreach(  @alts  ) {
	    if(  m#^~([^/]+)#  ) {	# Expand ~user to user's home directory:
		$user= $1 || getlogin();	# ~/ means "my" home directory
		$home= $1 ? ( (getpwnam($1))[7] || "~$user" )
			  : ( (getpwuid($<))[7] || $ENV{'HOME'} || "/" );
		s##$home#;
		# Replace "~user" with user's home directory (unless no such
		# user, then leave as is), unless is "~/" and getlogin()
		# failed, then try by current UID then $HOME then "/".
	    }
	    if(  m#(^|[^\\])(\\\\)*[\[\?\*]#  ) {   # Some kind of wildcard:
		push( @return, &pglob($_) );	    # Find matching files.
	    } else {		    # Just a string, perhaps with \-quoting:
		s/\\(.)/\1/g;	    # Remove the \'s used for quoting.
		push( @return, $_ );
	    }
	}
    }
    @return;
}

# &unbrac( $str ) - Expands a string containing "{a,b}" constructs.  Returns
# an array of strings.  "\" may be used to quote "{", ",", or "}" to suppress
# its special meaning (the "\"s are left in the returned strings).
#   This is a more efficient method than &glob() to expand these contructs
# where no file wildcards are involved.

sub unbrac {
  local( $glob )= @_;
  local( $pos, $bef, @bef, $temp, $mid, @mid, $aft, @aft, @return );
    $pos= rindex($glob,"{");	# Find the last "{"			    #}}
    while(  0 <= $pos  ) {	# Until there are no more "{"s to find:	    #}
	$bef= substr( $glob, 0, $pos );		# Part before "{"	    #}
	$temp= substr( $glob, 1 + $pos );	# Part after "{"	    #}
	if(  $bef =~ m#(^|[^\\])(\\\\)*$#  ) {	# The "{" is unquoted:	    #}{
	    $pos= index( $temp, "}" );		#{ Find the next nearest "}"
	    while(  0 <= $pos  ) {		#{ Until we run out of "}"s:
		$mid= substr( $temp, 0, $pos );	# Part between "{" and "}"  #{
		$aft= substr( $temp, 1 + $pos );	# Part after "}"
		if(  $mid =~ m#(^|[^\\])(\\\\)*$#  ) {	#{ The "}" is unquoted:
		    $mid =~ s/((^|[^\\])(\\\\))*,/\1\0/g; # Most unquoted ","s
		    $mid =~ s/((^|[^\\])(\\\\))*,/\1\0/g; # Remaining ones
		    return &mcat( $bef, $aft, split(/\0/,$mid) );	# Done!
		}	# &mcat builds all of the resulting strings.
	    }		# &mcat also "unbrac"s $bef and $aft.
	    if(  $Debug  ) {
		die "Unclosed `{' in pattern string: `",		#}
		  $bef, "' . `{' . `", $aft, "'\n";			#}
	    }
	}
	$pos= rindex( $glob, "{", $pos - 1 );				#}
    }
    ( $glob );	# No unquoted "{"s to be expanded			#}
}

# &File::KGlob::mcat( $bef, $aft, @mids ) - Used by &unbrac to make the code
# easier to follow.  Builds all of the strings  $bef . $mids[$i] . $aft  and
# then calls &unbrac on each of them.

sub mcat {
  local( $bef, $aft, @mid )= @_;
  local( @bef, @aft, $one, $two, $three, @return );
    foreach(  @mid  ) {
	push(  @return,  &unbrac( $bef . $_ . $aft )  );
    }