dosglob.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

#!perl -w

# use strict fails
#Can't use string ("main::glob") as a symbol ref while "strict refs" in use at /usr/lib/perl5/5.005/File/DosGlob.pm line 191.

#
# Documentation at the __END__
#

package File::DosGlob;

our $VERSION = '1.00';
use strict;
use warnings;

sub doglob {
    my $cond = shift;
    my @retval = ();
    #print "doglob: ", join('|', @_), "\n";
  OUTER:
    for my $pat (@_) {
	my @matched = ();
	my @globdirs = ();
	my $head = '.';
	my $sepchr = '/';
        my $tail;
	next OUTER unless defined $pat and $pat ne '';
	# if arg is within quotes strip em and do no globbing
	if ($pat =~ /^"(.*)"\z/s) {
	    $pat = $1;
	    if ($cond eq 'd') { push(@retval, $pat) if -d $pat }
	    else              { push(@retval, $pat) if -e $pat }
	    next OUTER;
	}
	# wildcards with a drive prefix such as h:*.pm must be changed
	# to h:./*.pm to expand correctly
	if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) {
	    substr($_,0,2) = $1 . "./";
	}
	if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) {
	    ($head, $sepchr, $tail) = ($1,$2,$3);
	    #print "div: |$head|$sepchr|$tail|\n";
	    push (@retval, $pat), next OUTER if $tail eq '';
	    if ($head =~ /[*?]/) {
		@globdirs = doglob('d', $head);
		push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
		    next OUTER if @globdirs;
	    }
	    $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s;
	    $pat = $tail;
	}
	#
	# If file component has no wildcards, we can avoid opendir
	unless ($pat =~ /[*?]/) {
	    $head = '' if $head eq '.';
	    $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
	    $head .= $pat;
	    if ($cond eq 'd') { push(@retval,$head) if -d $head }
	    else              { push(@retval,$head) if -e $head }
	    next OUTER;
	}
	opendir(D, $head) or next OUTER;
	my @leaves = readdir D;
	closedir D;
	$head = '' if $head eq '.';
	$head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;

	# escape regex metachars but not glob chars
        $pat =~ s:([].+^\-\${}[|]):\\$1:g;
	# and convert DOS-style wildcards to regex
	$pat =~ s/\*/.*/g;
	$pat =~ s/\?/.?/g;

	#print "regex: '$pat', head: '$head'\n";
	my $matchsub = sub { $_[0] =~ m|^$pat\z|is };
      INNER:
	for my $e (@leaves) {
	    next INNER if $e eq '.' or $e eq '..';
	    next INNER if $cond eq 'd' and ! -d "$head$e";
	    push(@matched, "$head$e"), next INNER if &$matchsub($e);
	    #
	    # [DOS compatibility special case]
	    # Failed, add a trailing dot and try again, but only
	    # if name does not have a dot in it *and* pattern
	    # has a dot *and* name is shorter than 9 chars.
	    #
	    if (index($e,'.') == -1 and length($e) < 9
	        and index($pat,'\\.') != -1) {
		push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
	    }
	}
	push @retval, @matched if @matched;
    }
    return @retval;
}


#
# Do DOS-like globbing on Mac OS 
#
sub doglob_Mac {
    my $cond = shift;
    my @retval = ();

	#print "doglob_Mac: ", join('|', @_), "\n";
  OUTER:
    for my $arg (@_) {
        local $_ = $arg;
	my @matched = ();
	my @globdirs = ();
	my $head = ':';
	my $not_esc_head = $head;
	my $sepchr = ':';	
	next OUTER unless defined $_ and $_ ne '';
	# if arg is within quotes strip em and do no globbing
	if (/^"(.*)"\z/s) {
	    $_ = $1;
		# $_ may contain escaped metachars '\*', '\?' and '\'
	        my $not_esc_arg = $_;
		$not_esc_arg =~ s/\\([*?\\])/$1/g;
	    if ($cond eq 'd') { push(@retval, $not_esc_arg) if -d $not_esc_arg }
	    else              { push(@retval, $not_esc_arg) if -e $not_esc_arg }
	    next OUTER;
	}

	if (m|^(.*?)(:+)([^:]*)\z|s) { # note: $1 is not greedy
	    my $tail;
	    ($head, $sepchr, $tail) = ($1,$2,$3);
	    #print "div: |$head|$sepchr|$tail|\n";
	    push (@retval, $_), next OUTER if $tail eq '';		
		#
		# $head may contain escaped metachars '\*' and '\?'
		
		my $tmp_head = $head;
		# if a '*' or '?' is preceded by an odd count of '\', temporary delete 
		# it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as 
		# wildcards
		$tmp_head =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg;
	
		if ($tmp_head =~ /[*?]/) { # if there are wildcards ...	
		@globdirs = doglob_Mac('d', $head);
		push(@retval, doglob_Mac($cond, map {"$_$sepchr$tail"} @globdirs)),
		    next OUTER if @globdirs;
	    }
		
		$head .= $sepchr; 
		$not_esc_head = $head;
		# unescape $head for file operations
		$not_esc_head =~ s/\\([*?\\])/$1/g;
	    $_ = $tail;
	}
	#
	# If file component has no wildcards, we can avoid opendir
	
	my $tmp_tail = $_;
	# if a '*' or '?' is preceded by an odd count of '\', temporary delete 
	# it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as 
	# wildcards
	$tmp_tail =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg;
	
	unless ($tmp_tail =~ /[*?]/) { # if there are wildcards ...
	    $not_esc_head = $head = '' if $head eq ':';
	    my $not_esc_tail = $_;
	    # unescape $head and $tail for file operations
	    $not_esc_tail =~ s/\\([*?\\])/$1/g;
	    $head .= $_;
		$not_esc_head .= $not_esc_tail;
	    if ($cond eq 'd') { push(@retval,$head) if -d $not_esc_head }
	    else              { push(@retval,$head) if -e $not_esc_head }
	    next OUTER;
	}
	#print "opendir($not_esc_head)\n";
	opendir(D, $not_esc_head) or next OUTER;
	my @leaves = readdir D;
	closedir D;

	# escape regex metachars but not '\' and glob chars '*', '?'
	$_ =~ s:([].+^\-\${}[|]):\\$1:g;
	# and convert DOS-style wildcards to regex,
	# but only if they are not escaped
	$_ =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg;

	#print "regex: '$_', head: '$head', unescaped head: '$not_esc_head'\n";
	my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }';
	warn($@), next OUTER if $@;
      INNER:
	for my $e (@leaves) {
	    next INNER if $e eq '.' or $e eq '..';
	    next INNER if $cond eq 'd' and ! -d "$not_esc_head$e";
		
		if (&$matchsub($e)) {
			my $leave = (($not_esc_head eq ':') && (-f "$not_esc_head$e")) ? 
		            	"$e" : "$not_esc_head$e";
			#
			# On Mac OS, the two glob metachars '*' and '?' and the escape 
			# char '\' are valid characters for file and directory names. 
			# We have to escape and treat them specially.
			$leave =~ s|([*?\\])|\\$1|g;		
			push(@matched, $leave);
			next INNER;
		}
	}
	push @retval, @matched if @matched;
    }
    return @retval;
}

#
# _expand_volume() will only be used on Mac OS (Classic): 
# Takes an array of original patterns as argument and returns an array of  
# possibly modified patterns. Each original pattern is processed like 
# that:
# + If there's a volume name in the pattern, we push a separate pattern 
#   for each mounted volume that matches (with '*', '?' and '\' escaped).  
# + If there's no volume name in the original pattern, it is pushed 
#   unchanged. 
# Note that the returned array of patterns may be empty.
#  
sub _expand_volume {
	
	require MacPerl; # to be verbose
	
	my @pat = @_;
	my @new_pat = ();
	my @FSSpec_Vols = MacPerl::Volumes();
	my @mounted_volumes = ();

	foreach my $spec_vol (@FSSpec_Vols) {		
		# push all mounted volumes into array
     	push @mounted_volumes, MacPerl::MakePath($spec_vol);
	}
	#print "mounted volumes: |@mounted_volumes|\n";
	
	while (@pat) {
		my $pat = shift @pat;	
		if ($pat =~ /^([^:]+:)(.*)\z/) { # match a volume name?
			my $vol_pat = $1;
			my $tail = $2;
			#
			# escape regex metachars but not '\' and glob chars '*', '?'
			$vol_pat =~ s:([].+^\-\${}[|]):\\$1:g;
			# and convert DOS-style wildcards to regex,
			# but only if they are not escaped
			$vol_pat =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg;
			#print "volume regex: '$vol_pat' \n";
				
			foreach my $volume (@mounted_volumes) {
				if ($volume =~ m|^$vol_pat\z|ios) {
					#
					# On Mac OS, the two glob metachars '*' and '?' and the  
					# escape char '\' are valid characters for volume names. 
					# We have to escape and treat them specially.
					$volume =~ s|([*?\\])|\\$1|g;
					push @new_pat, $volume . $tail;
				}
			}			
		} else { # no volume name in pattern, push original pattern
			push @new_pat, $pat;
		}
	}
	return @new_pat;
}


#
# _preprocess_pattern() will only be used on Mac OS (Classic): 
# Resolves any updirs in the pattern. Removes a single trailing colon 
# from the pattern, unless it's a volume name pattern like "*HD:"
#
sub _preprocess_pattern {
	my @pat = @_;
	
	foreach my $p (@pat) {
		my $proceed;
		# resolve any updirs, e.g. "*HD:t?p::a*" -> "*HD:a*"
		do {
			$proceed = ($p =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/);  
		} while ($proceed);
		# remove a single trailing colon, e.g. ":*:" -> ":*"
		$p =~ s/:([^:]+):\z/:$1/;
	}
	return @pat;
}
		
		
#