readline.pm

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

    if ($default ne '') {
	my $func = $KeyMap{'default'} = "F_$default";
	### Temporarily disabled
	die qq/Bad default function [$func] for keymap "$name"/
	  if !$autoload_broken and !defined(&$func);
    }

    &rl_bind if @_ > 0;	## The rest of @_ gets passed silently.
}

##
## Accepts an array as pairs ($keyspec, $function, [$keyspec, $function]...).
## and maps the associated bindings to the current KeyMap.
##
## keyspec should be the name of key sequence in one of two forms:
##
## Old (GNU readline documented) form:
##	     M-x	to indicate Meta-x
##	     C-x	to indicate Ctrl-x
##	     M-C-x	to indicate Meta-Ctrl-x
##	     x		simple char x
##      where 'x' above can be a single character, or the special:
##          special  	means
##         --------  	-----
##	     space	space   ( )
##	     spc	space   ( )
##	     tab	tab     (\t)
##	     del	delete  (0x7f)
##	     rubout	delete  (0x7f)
##	     newline 	newline (\n)
##	     lfd     	newline (\n)
##	     ret     	return  (\r)
##	     return  	return  (\r)
##	     escape  	escape  (\e)
##	     esc     	escape  (\e)
##
## New form:
##	  "chars"   (note the required double-quotes)
##   where each char in the list represents a character in the sequence, except
##   for the special sequences:
##	  \\C-x		Ctrl-x
##	  \\M-x		Meta-x
##	  \\M-C-x	Meta-Ctrl-x
##	  \\e		escape.
##	  \\x		x (if not one of the above)
##
##
## FUNCTION should be in the form 'BeginningOfLine' or 'beginning-of-line'.
## It is an error for the function to not be known....
##
## As an example, the following lines in .inputrc will bind one's xterm
## arrow keys:
##     "\e[[A": previous-history
##     "\e[[B": next-history
##     "\e[[C": forward-char
##     "\e[[D": backward-char
##

sub filler_Pending ($) {
  my $keys = shift;
  sub {
    my $c = shift;
    push @Pending, map chr, @$keys;
    return if not @$keys or $c == 1 or not defined(my $in = &getc_with_pending);
    # provide the numeric argument
    local(*KeyMap) = $var_EditingMode;
    $doingNumArg = 1;		# Allow NumArg inside NumArg
    &do_command(*KeyMap, $c, ord $in);
    return;
  }
}

sub _unescape ($) {
  my($key, @keys) = shift;
  ## New-style bindings are enclosed in double-quotes.
  ## Characters are taken verbatim except the special cases:
  ##    \C-x    Control x (for any x)
  ##    \M-x    Meta x (for any x)
  ##    \e	  Escape
  ##    \*      Set the keymap default   (JP: added this)
  ##               (must be the last character of the sequence)
  ##
  ##    \x      x  (unless it fits the above pattern)
  ##
  ## Look for special case of "\C-\M-x", which should be treated
  ## like "\M-\C-x".

  while (length($key) > 0) {

    # JP: fixed regex bugs below: changed all 's#' to 's#^'

    if ($key =~ s#^\\C-\\M-(.)##) {
      push(@keys, ord("\e"), &ctrl(ord($1)));
    } elsif ($key =~ s#^\\(M-|e)##) {
      push(@keys, ord("\e"));
    } elsif ($key =~ s#^\\C-(.)##) {
      push(@keys, &ctrl(ord($1)));
    } elsif ($key =~ s#^\\x([0-9a-fA-F]{2})##) {
      push(@keys, eval('0x'.$1));
    } elsif ($key =~ s#^\\([0-7]{3})##) {
      push(@keys, eval('0'.$1));
    } elsif ($key =~ s#^\\\*$##) {     # JP: added
      push(@keys, 'default');
    } elsif ($key =~ s#^\\([afnrtv])##) {
      push(@keys, ord(eval(qq("\\$1"))));
    } elsif ($key =~ s#^\\d##) {
      push(@keys, 4);		# C-d
    } elsif ($key =~ s#^\\b##) {
      push(@keys, 0x7f);	# Backspace
    } elsif ($key =~ s#^\\(.)##) {
      push(@keys, ord($1));
    } else {
      push(@keys, ord($key));
      substr($key,0,1) = '';
    }
  }
  @keys
}

sub RL_func ($) {
  my $name_or_macro = shift;
  if ($name_or_macro =~ /^"((?:\\.|[^\\\"])*)"|^'((?:\\.|[^\\\'])*)'/s) {
    filler_Pending [_unescape "$+"];
  } else {
    "F_$name_or_macro";
  }
}

sub actually_do_binding
{
  ##
  ## actually_do_binding($function1, \@sequence1, ...)
  ##
  ## Actually inserts the binding for @sequence to $function into the
  ## current map.  @sequence is an array of character ordinals.
  ##
  ## If @sequence is more than one element long, all but the last will
  ## cause meta maps to be created.
  ##
  ## $Function will have an implicit "F_" prepended to it.
  ##
  while (@_) {
    my $func = shift;
    my ($key, @keys) = @{shift()};
    $key += 0;
    local(*KeyMap) = *KeyMap;
    my $map;
    while (@keys) {
      if (defined($KeyMap[$key]) && ($KeyMap[$key] ne 'F_PrefixMeta')) {
	warn "Warning$InputLocMsg: ".
	  "Re-binding char #$key from [$KeyMap[$key]] to meta for [@keys] => $func.\n" if $^W;
      }
      $KeyMap[$key] = 'F_PrefixMeta';
      $map = "$KeyMap{'name'}_$key";
      InitKeymap(*$map, '', $map) if !(%$map);
      *KeyMap = *$map;
      $key = shift @keys;
      #&actually_do_binding($func, \@keys);
    }

    my $name = $KeyMap{'name'};
    if ($key eq 'default') {      # JP: added
	warn "Warning$InputLocMsg: ".
	  " changing default action to $func in $name key map\n"
	  if $^W && defined $KeyMap{'default'};

	$KeyMap{'default'} = RL_func $func;
    }
    else {
	if (defined($KeyMap[$key]) && $KeyMap[$key] eq 'F_PrefixMeta'
	    && $func ne 'PrefixMeta')
	  {
	    warn "Warning$InputLocMsg: ".
	      " Re-binding char #$key to non-meta ($func) in $name key map\n"
	      if $^W;
	  }
	$KeyMap[$key] = RL_func $func;
    }
  }
}

sub rl_bind
{
    my (@keys, $key, $func, $ord, @arr);

    while (defined($key = shift(@_)) && defined($func = shift(@_)))
    {
	##
	## Change the function name from something like
	##	backward-kill-line
	## to
	##	BackwardKillLine
	## if not already there.
	##
        unless ($func =~ /^[\"\']/) {
	  $func = "\u$func";
	  $func =~ s/-(.)/\u$1/g;

	  # Temporary disabled
	  if (!$autoload_broken and !defined($ {'readline::'}{"F_$func"})) {
	    warn "Warning$InputLocMsg: bad bind function [$func]\n" if $^W;
	    next;
	  }
	}

	## print "sequence [$key] func [$func]\n"; ##DEBUG

	@keys = ();
 	## See if it's a new-style binding.
	if ($key =~ m/"((?:\\.|[^\\])*)"/s) {
	    @keys = _unescape "$1";
	} else {
	    ## ol-dstyle binding... only one key (or Meta+key)
	    my ($isctrl, $orig) = (0, $key);
	    $isctrl = $key =~ s/\b(C|Control|CTRL)-//i;
	    push(@keys, ord("\e")) if $key =~ s/\b(M|Meta)-//i; ## is meta?
	    ## Isolate key part. This matches GNU's implementation.
	    ## If the key is '-', be careful not to delete it!
	    $key =~ s/.*-(.)/$1/;
	    if    ($key =~ /^(space|spc)$/i)   { $key = ' ';    }
	    elsif ($key =~ /^(rubout|del)$/i)  { $key = "\x7f"; }
	    elsif ($key =~ /^tab$/i)           { $key = "\t";   }
	    elsif ($key =~ /^(return|ret)$/i)  { $key = "\r";   }
	    elsif ($key =~ /^(newline|lfd)$/i) { $key = "\n";   }
	    elsif ($key =~ /^(escape|esc)$/i)  { $key = "\e";   }
	    elsif (length($key) > 1) {
	        warn "Warning$InputLocMsg: strange binding [$orig]\n" if $^W;
	    }
	    $key = ord($key);
	    $key = &ctrl($key) if $isctrl;
	    push(@keys, $key);
	}

	# 
	## Now do the mapping of the sequence represented in @keys
	 #
	# print "&actually_do_binding($func, @keys)\n"; ##DEBUG
	push @arr, $func, [@keys];
	#&actually_do_binding($func, \@keys);
    }
    &actually_do_binding(@arr);
}

sub read_an_init_file {
    my $file = shift;
    my $include_depth = shift;
    local *RC;
    $file =~ s/^~([\\\/])/$ENV{HOME}$1/ if not -f $file and exists $ENV{HOME};
    return unless open RC, "< $file";
    my (@action) = ('exec'); ## exec, skip, ignore (until appropriate endif)
    my (@level) = ();        ## if, else

    local $/ = "\n";
    while (<RC>) {
	s/^\s+//;
	next if m/^\s*(#|$)/;
	$InputLocMsg = " [$file line $.]";
	if (/^\$if\s+(.*)/) {
	    my($test) = $1;
	    push(@level, 'if');
	    if ($action[$#action] ne 'exec') {
		## We're supposed to be skipping or ignoring this level,
		## so for subsequent levels we really ignore completely.
		push(@action, 'ignore');
	    } else {
		## We're executing this IF... do the test.
		## The test is either "term=xxxx", or just a string that
		## we compare to $rl_readline_name;
		if ($test =~ /term=([a-z0-9]+)/) {
		    $test = ($ENV{'TERM'} && $1 eq $ENV{'TERM'});
		} else {
		    $test = $test =~ /^(perl|$rl_readline_name)\s*$/i;
		}
		push(@action, $test ? 'exec' : 'skip');
	    }
	    next;
	} elsif (/^\$endif\b/) {
	    die qq/\rWarning$InputLocMsg: unmatched endif\n/ if @level == 0;
	    pop(@level);
	    pop(@action);
	    next;
	} elsif (/^\$else\b/) {
	    die qq/\rWarning$InputLocMsg: unmatched else\n/ if
		@level == 0 || $level[$#level] ne 'if';
	    $level[$#level] = 'else'; ## an IF turns into an ELSE
	    if ($action[$#action] eq 'skip') {
		$action[$#action] = 'exec'; ## if were SKIPing, now EXEC
	    } else {
		$action[$#action] = 'ignore'; ## otherwise, just IGNORE.
	    }
	    next;
	} elsif (/^\$include\s+(\S+)/) {
	    if ($include_depth > $max_include_depth) {
		warn "Deep recursion in \$include directives in $file.\n";
	    } else {
		read_an_init_file($1, $include_depth + 1);
	    }
	} elsif ($action[$#action] ne 'exec') {
	    ## skipping this one....
	# readline permits trailing comments in inputrc
	# this seems to solve the warnings caused by trailing comments in the
	# default /etc/inputrc on Mandrake Linux boxes.
	} elsif (m/\s*set\s+(\S+)\s+(\S*)/) {	# Allow trailing comment
	    &rl_set($1, $2, $file);
	} elsif (m/^\s*(\S+):\s+("(?:\\.|[^\\\"])*"|'(\\.|[^\\\'])*')/) {	# Allow trailing comment
	    &rl_bind($1, $2);
	} elsif (m/^\s*(\S+):\s+(\S+)/) {	# Allow trailing comment
	    &rl_bind($1, $2);
	} else {
	    chomp;
	    warn "\rWarning$InputLocMsg: Bad line [$_]\n" if $^W;
	}
    }
    close(RC);
}

sub F_ReReadInitFile
{
    my ($file) = $ENV{'TRP_INPUTRC'};
    $file = $ENV{'INPUTRC'} unless defined $file;
    unless (defined $file) {
	return unless defined $ENV{'HOME'};
	$file = "$ENV{'HOME'}/.inputrc";
    }
    read_an_init_file($file, 0);
}

sub get_ornaments_selected {
    return if @$rl_term_set >= 6;
    local $^W=0;
    my $Orig = $Term::ReadLine::Perl::term->ornaments(); 
    eval {
        # Term::ReadLine does not expose its $terminal, so make another
        require Term::Cap;
        my $terminal = Tgetent Term::Cap ({OSPEED=>9600});
        # and be sure the terminal supports highlighting
        $terminal->Trequire('mr');
    };
    if (!$@ and $Orig ne ',,,'){
	my @set = @$rl_term_set;

        $Term::ReadLine::Perl::term->ornaments
            (join(',', (split(/,/, $Orig))[0,1]) . ',mr,me') ;
        @set[4,5] = @$rl_term_set[2,3];
        $Term::ReadLine::Perl::term->ornaments($Orig);
	@$rl_term_set = @set;
    } else {
        @$rl_term_set[4,5] = @$rl_term_set[2,3];
    }
}

sub readline_dumb {
	local $\ = '';
	print $term_OUT $prompt;
	local $/ = "\n";
	return undef
          if !defined($line = $Term::ReadLine::Perl::term->get_line);
	chomp($line);
	$| = $oldbar;
	select $old;
	return $line;
}

##
## This is it. Called as &readline'readline($prompt, $default),
## (DEFAULT can be omitted) the next input line is returned (undef on EOF).
##
sub readline
{
    $Term::ReadLine::Perl::term->register_Tk 
      if not $Term::ReadLine::registered and $Term::ReadLine::toloop
	and defined &Tk::DoOneEvent;
    if ($stdin_not_tty) {
	local $/ = "\n";
	return undef if !defined($line = <$term_IN>);
	chomp($line);
	return $line;
    }