readline.pm

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

    $old = select $term_OUT;
    $oldbar = $|;
    local($|) = 1;
    local($input);

    ## prompt should be given to us....
    $prompt = defined($_[0]) ? $_[0] : 'INPUT> ';

    # Try to move cursor to the beginning of the next line if this line
    # contains anything.

    # On DOSish 80-wide console
    #	perl -we "print 1 x shift, qq(\b2\r3); sleep 2" 79
    # prints 3 on the same line,
    #	perl -we "print 1 x shift, qq(\b2\r3); sleep 2" 80
    # on the next; $rl_screen_width is 79.

    # on XTerm one needs to increase the number by 1.

    print $term_OUT ' ' x ($rl_screen_width - !$rl_last_pos_can_backspace) . "\b  \r"
      if $rl_scroll_nextline;

    if ($dumb_term) {
	return readline_dumb;
    }

    # test if we resume an 'Operate' command
    if ($rl_OperateCount > 0 && (!defined $_[1] || $_[1] eq '')) {
	## it's from a valid previous 'Operate' command and
	## user didn't give a default line
	## we leave $rl_HistoryIndex untouched
	$line = $rl_History[$rl_HistoryIndex];
    } else {
	## set history pointer at the end of history
	$rl_HistoryIndex = $#rl_History + 1;
	$rl_OperateCount = 0;
	$line = defined $_[1] ? $_[1] : '';
    }
    $rl_OperateCount-- if $rl_OperateCount > 0;

    $line_for_revert = $line;

# I don't think we need to do this, actually...
#    while (&ioctl(STDIN,$FIONREAD,$fion))
#    {
#	local($n_chars_available) = unpack ($fionread_t, $fion);
#	## print "n_chars = $n_chars_available\n";
#	last if $n_chars_available == 0;
#	$line .= getc_with_pending;  # should we prepend if $rl_start_default_at_beginning?
#    }

    $D = $rl_start_default_at_beginning ? 0 : length($line); ## set dot.
    $LastCommandKilledText = 0;     ## heck, was no last command.
    $lastcommand = '';		    ## Well, there you go.
    $line_rl_mark = -1;

    ##
    ## some stuff for &redisplay.
    ##
    $lastredisplay = '';	## Was no last redisplay for this time.
    $lastlen = length($lastredisplay);
    $lastpromptlen = 0;
    $lastdelta = 0;		## Cursor was nowhere
    $si = 0;			## Want line to start left-justified
    $force_redraw = 1;		## Want to display with brute force.
    if (!eval {SetTTY()}) {	## Put into raw mode.
        warn $@ if $@;
        $dumb_term = 1;
	return readline_dumb;
    }

    *KeyMap = $var_EditingMode;
    undef($AcceptLine);		## When set, will return its value.
    undef($ReturnEOF);		## ...unless this on, then return undef.
    @Pending = ();		## Contains characters to use as input.
    @undo = ();			## Undo history starts empty for each line.
    @undoGroupS = ();		## Undo groups start empty for each line.
    undef $memorizedArg;	## No digitArgument memorized
    undef $memorizedPos;	## No position memorized

    undef $Vi_undo_state;
    undef $Vi_undo_all_state;

    # We need to do some additional initialization for vi mode.
    # RS: bug reports/platform issues are welcome: [e-mail]
    if ($KeyMap{'name'} eq 'vi_keymap'){
        &F_ViInput();
        if ($rl_vi_replace_default_on_insert){
            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 ',,,'){
               $Term::ReadLine::Perl::term->ornaments
                   (join(',', (split(/,/, $Orig))[0,1]) . ',mr,me') 
           }
            my $F_SelfInsert_Real = \&F_SelfInsert;
            *F_SelfInsert = sub {
               $Term::ReadLine::Perl::term->ornaments($Orig); 
                &F_ViChangeEntireLine;
                local $^W=0;
                *F_SelfInsert = $F_SelfInsert_Real;
                &F_SelfInsert;
            };
            my $F_ViEndInsert_Real = \&F_ViEndInsert;
            *F_ViEndInsert = sub {
               $Term::ReadLine::Perl::term->ornaments($Orig); 
                local $^W=0;
                *F_SelfInsert = $F_SelfInsert_Real;
                *F_ViEndInsert = $F_ViEndInsert_Real;
                &F_ViEndInsert;
               $force_redraw = 1;
               redisplay();
            };
        }
    }

    if ($rl_default_selected) {
	redisplay_high();
    } else {
	&redisplay();          ## Show the line (prompt+default at this point).
    }

    # pretend input if we 'Operate' on more than one line
    &F_OperateAndGetNext($rl_OperateCount) if $rl_OperateCount > 0;

    $rl_first_char = 1;
    while (!defined($AcceptLine)) {
	## get a character of input
	$input = &getc_with_pending(); # bug in debugger, returns 42. - No more!

	unless (defined $input) {
	  # XXX What to do???  Until this is clear, just pretend we got EOF
	  $AcceptLine = $ReturnEOF = 1;
	  last;
	}
	preserve_state();

	$ThisCommandKilledText = 0;
	##print "\n\rline is @$D:[$line]\n\r"; ##DEBUG
	my $cmd = get_command($var_EditingMode, ord($input));
	if ( $rl_first_char && $cmd =~ /^F_(SelfInsert$|Yank)/
	     && length $line && $rl_default_selected ) {
	  # (Backward)?DeleteChar specialcased in the code
	    $line = '';
	    $D = 0;
	    $cmd = 'F_BackwardDeleteChar' if $cmd eq 'F_DeleteChar';
	}
	undef $doingNumArg;
	&$cmd(1, ord($input));			## actually execute input
	$rl_first_char = 0;
	$lastcommand = $cmd;
	*KeyMap = $var_EditingMode;           # JP: added

	# In Vi command mode, don't position the cursor beyond the last
	#     character of the line buffer.
	&F_BackwardChar(1) if $Vi_mode and $line ne ''
	    and &at_end_of_line and $KeyMap{'name'} eq 'vicmd_keymap';

	&redisplay();
	$LastCommandKilledText = $ThisCommandKilledText;
    }

    undef @undo; ## Release the memory.
    undef @undoGroupS; ## Release the memory.
    &ResetTTY;   ## Restore the tty state.
    $| = $oldbar;
    select $old;
    return undef if defined($ReturnEOF);
    #print STDOUT "|al=`$AcceptLine'";
    $AcceptLine; ## return the line accepted.
}

## ctrl(ord('a')) will return the ordinal for Ctrl-A.
sub ctrl {
  $_[0] ^ (($_[0]>=ord('a') && $_[0]<=ord('z')) ? 0x60 : 0x40);
}



sub SetTTY {
    return if $dumb_term || $stdin_not_tty;
    #return system 'stty raw -echo' if defined &DB::DB;
    if (defined $term_readkey) {
      Term::ReadKey::ReadMode(4, $term_IN);
      if ($^O eq 'MSWin32') {
	# If we reached this, Perl isn't cygwin; Enter sends \r; thus we need binmode
	# XXXX Do we need to undo???  $term_IN is most probably private now...
	binmode $term_IN;
      }
      return 1;
    }
#   system 'stty raw -echo';

    $sgttyb = ''; ## just to quiet "perl -w";
  if ($useioctl && $^O ne 'solaris' && defined $TIOCGETP
      && &ioctl($term_IN,$TIOCGETP,$sgttyb)) {
    @tty_buf = unpack($sgttyb_t,$sgttyb);
    if (defined $ENV{OS2_SHELL}) {
      $tty_buf[3] &= ~$mode;
      $tty_buf[3] &= ~$ECHO;
    } else {
      $tty_buf[4] |= $mode;
      $tty_buf[4] &= ~$ECHO;
    }
    $sgttyb = pack($sgttyb_t,@tty_buf);
    &ioctl($term_IN,$TIOCSETP,$sgttyb) || die "Can't ioctl TIOCSETP: $!";
  } elsif (!$usestty) {
    return 0;
  } else {
     warn <<EOW if $useioctl and not defined $ENV{PERL_READLINE_NOWARN};
Can't ioctl TIOCGETP: $!
Consider installing Term::ReadKey from CPAN site nearby
	at http://www.perl.com/CPAN
Or use
	perl -MCPAN -e shell
to reach CPAN. Falling back to 'stty'.
	If you do not want to see this warning, set PERL_READLINE_NOWARN
in your environment.
EOW
					# '; # For Emacs. 
     $useioctl = 0;
     system 'stty raw -echo' and ($usestty = 0, die "Cannot call `stty': $!");
     if ($^O eq 'MSWin32') {
	# If we reached this, Perl isn't cygwin, but STTY is present ==> cygwin
	# The symptoms: now Enter sends \r; thus we need binmode
	# XXXX Do we need to undo???  $term_IN is most probably private now...
	binmode $term_IN;
     }
  }
  return 1;
}

sub ResetTTY {
    return if $dumb_term || $stdin_not_tty;
    #return system 'stty -raw echo' if defined &DB::DB;
    if (defined $term_readkey) {
      return Term::ReadKey::ReadMode(0, $term_IN);
    }

#   system 'stty -raw echo';
  if ($useioctl) {
    &ioctl($term_IN,$TIOCGETP,$sgttyb) || die "Can't ioctl TIOCGETP: $!";
    @tty_buf = unpack($sgttyb_t,$sgttyb);
    if (defined $ENV{OS2_SHELL}) {
      $tty_buf[3] |= $mode;
      $tty_buf[3] |= $ECHO;
    } else {
      $tty_buf[4] &= ~$mode;
      $tty_buf[4] |= $ECHO;
    }
    $sgttyb = pack($sgttyb_t,@tty_buf);
    &ioctl($term_IN,$TIOCSETP,$sgttyb) || die "Can't ioctl TIOCSETP: $!";
  } elsif ($usestty) {
    system 'stty -raw echo' and die "Cannot call `stty': $!";
  }
}

# Substr_with_props: gives the substr of prompt+string with embedded
# face-change commands

sub substr_with_props {
  my ($p, $s, $from, $len, $ket, $bsel, $esel) = @_;
  my $lp = length $p;

  defined $from or $from = 0;
  defined $len or $len = length($p) + length($s) - $from;
  unless (defined $ket) {
    warn 'bug in Term::ReadLine::Perl, please report to its author [e-mail]';
    $ket = '';
  }
  # We may draw over to put cursor in a correct position:
  $ket = '' if $len < length($p) + length($s) - $from; # Not redrawn

  if ($from >= $lp) {
    $p = '';
    $s = substr $s, $from - $lp;
    $lp = 0;
  } else {
    $p = substr $p, $from;
    $lp -= $from;
    $from = 0;
  }
  $s = substr $s, 0, $len - $lp;
  $p =~ s/^(\s*)//; my $bs = $1;
  $p =~ s/(\s*)$//; my $as = $1;
  $p = $rl_term_set->[0] . $p . $rl_term_set->[1] if length $p;
  $p = "$bs$p$as";
  $ket = chop $s if $ket;
  if (defined $bsel and $bsel != $esel) {
    $bsel = $len if $bsel > $len;
    $esel = $len if $esel > $len;
  }
  if (defined $bsel and $bsel != $esel) {
    get_ornaments_selected;
    $bsel -= $lp; $esel -= $lp;
    my ($pre, $sel, $post) =
      (substr($s, 0, $bsel),
       substr($s, $bsel, $esel-$bsel),
       substr($s, $esel));
    $pre  = $rl_term_set->[2] . $pre  . $rl_term_set->[3] if length $pre;
    $sel  = $rl_term_set->[4] . $sel  . $rl_term_set->[5] if length $sel;
    $post = $rl_term_set->[2] . $post . $rl_term_set->[3] if length $post;
    $s = "$pre$sel$post"
  } else {
    $s = $rl_term_set->[2] . $s . $rl_term_set->[3] if length $s;
  }

  if (!$lp) {			# Should not happen...
    return $s;
  } elsif (!length $s) {	# Should not happen
    return $p;
  } else {			# Do not underline spaces in the prompt
    return "$p$s"
      . (length $ket ? ($rl_term_set->[0] . $ket . $rl_term_set->[1]) : '');
  }
}

sub redisplay_high {
  get_ornaments_selected();
  @$rl_term_set[2,3,4,5] = @$rl_term_set[4,5,2,3];
  &redisplay();			## Show the line, default inverted.
  @$rl_term_set[2,3,4,5] = @$rl_term_set[4,5,2,3];
  $force_redraw = 1;
}

##
## redisplay()
##
## Updates the screen to reflect the current $line.
##
## For the purposes of this routine, we prepend the prompt to a local copy of
## $line so that we display the prompt as well.  We then modify it to reflect
## that some characters have different sizes (i.e. control-C is represented
## as ^C, tabs are expanded, etc.)
##
## This routine is somewhat complicated by two-byte characters.... must
## make sure never to try do display just half of one.
##
## NOTE: If an argument is given, it is used instead of the prompt.
##
## This is some nasty code.
##
sub redisplay
{
    ## local $line has prompt also; take that into account with $D.
    local($prompt) = defined($_[0]) ? $_[0] : $prompt;
    my ($thislen, $have_bra);
    my($dline) = $prompt . $line;
    local($D) = $D + length($prompt);
    my ($bsel, $esel);
    if (defined pos $line) {
      $bsel = (pos $line) + length $prompt;
    }
    my ($have_ket) = '';

    ##
    ## If the line contains anything that might require special processing
    ## for displaying (such as tabs, control characters, etc.), we will
    ## take care of that now....
    ##
    if ($dline =~ m/[^\x20-\x7e]/)
    {
	local($new, $Dinc, $c) = ('', 0);

	## Look at each character of $dline in turn.....
        for ($i = 0; $i < length($dline); $i++) {
	    $c = substr($dline, $i, 1);

	    ## A ta