concise.pm

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

	if (ref($maybe_root) and $maybe_root->isa("B::OP")) {
	    # It really is the root of the replacement, not something
	    # else stored here for lack of space elsewhere
	    walk_topdown($maybe_root, $sub, $level + 1);
	}
    }
}

sub walklines {
    my($ar, $level) = @_;
    for my $l (@$ar) {
	if (ref($l) eq "ARRAY") {
	    walklines($l, $level + 1);
	} else {
	    $l->concise($level);
	}
    }
}

sub walk_exec {
    my($top, $level) = @_;
    my %opsseen;
    my @lines;
    my @todo = ([$top, \@lines]);
    while (@todo and my($op, $targ) = @{shift @todo}) {
	for (; $$op; $op = $op->next) {
	    last if $opsseen{$$op}++;
	    push @$targ, $op;
	    my $name = $op->name;
	    if (class($op) eq "LOGOP") {
		my $ar = [];
		push @$targ, $ar;
		push @todo, [$op->other, $ar];
	    } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
		my $ar = [];
		push @$targ, $ar;
		push @todo, [$op->pmreplstart, $ar];
	    } elsif ($name =~ /^enter(loop|iter)$/) {
		if ($] > 5.009) {
		    $labels{${$op->nextop}} = "NEXT";
		    $labels{${$op->lastop}} = "LAST";
		    $labels{${$op->redoop}} = "REDO";
		} else {
		    $labels{$op->nextop->seq} = "NEXT";
		    $labels{$op->lastop->seq} = "LAST";
		    $labels{$op->redoop->seq} = "REDO";		
		}
	    }
	}
    }
    walklines(\@lines, 0);
}

# The structure of this routine is purposely modeled after op.c's peep()
sub sequence {
    my($op) = @_;
    my $oldop = 0;
    return if class($op) eq "NULL" or exists $sequence_num{$$op};
    for (; $$op; $op = $op->next) {
	last if exists $sequence_num{$$op};
	my $name = $op->name;
	if ($name =~ /^(null|scalar|lineseq|scope)$/) {
	    next if $oldop and $ {$op->next};
	} else {
	    $sequence_num{$$op} = $seq_max++;
	    if (class($op) eq "LOGOP") {
		my $other = $op->other;
		$other = $other->next while $other->name eq "null";
		sequence($other);
	    } elsif (class($op) eq "LOOP") {
		my $redoop = $op->redoop;
		$redoop = $redoop->next while $redoop->name eq "null";
		sequence($redoop);
		my $nextop = $op->nextop;
		$nextop = $nextop->next while $nextop->name eq "null";
		sequence($nextop);
		my $lastop = $op->lastop;
		$lastop = $lastop->next while $lastop->name eq "null";
		sequence($lastop);
	    } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
		my $replstart = $op->pmreplstart;
		$replstart = $replstart->next while $replstart->name eq "null";
		sequence($replstart);
	    }
	}
	$oldop = $op;
    }
}

sub fmt_line {    # generate text-line for op.
    my($hr, $op, $text, $level) = @_;

    $_->($hr, $op, \$text, \$level, $stylename) for @callbacks;

    return '' if $hr->{SKIP};	# suppress line if a callback said so
    return '' if $hr->{goto} and $hr->{goto} eq '-';	# no goto nowhere

    # spec: (?(text1#varText2)?)
    $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/
	$hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg;

    # spec: (x(exec_text;basic_text)x)
    $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs;

    # spec: (*(text)*)
    $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs;

    # spec: (*(text1;text2)*)
    $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs;

    # convert #Var to tag=>val form: Var\t#var
    $text =~ s/\#([A-Z][a-z]+)(\d+)?/\t\u$1\t\L#$1$2/gs;

    # spec: #varN
    $text =~ s/\#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg;

    $text =~ s/\#([a-zA-Z]+)/$hr->{$1}/eg;	# populate #var's
    $text =~ s/[ \t]*~+[ \t]*/ /g;		# squeeze tildes

    $text = "# $hr->{src}\n$text" if $show_src and $hr->{src};

    chomp $text;
    return "$text\n" if $text ne "";
    return $text; # suppress empty lines
}

our %priv; # used to display each opcode's BASEOP.op_private values

$priv{$_}{128} = "LVINTRO"
  for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv",
       "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv",
       "padav", "padhv", "enteriter");
$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite");
$priv{"aassign"}{64} = "COMMON";
$priv{"aassign"}{32} = $] < 5.009 ? "PHASH" : "STATE";
$priv{"sassign"}{32} = "STATE";
$priv{"sassign"}{64} = "BKWARD";
$priv{$_}{64} = "RTIME" for ("match", "subst", "substcont", "qr");
@{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL",
				    "COMPL", "GROWS");
$priv{"repeat"}{64} = "DOLIST";
$priv{"leaveloop"}{64} = "CONT";
@{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV")
  for (qw(rv2gv rv2sv padsv aelem helem));
$priv{$_}{16} = "STATE" for ("padav", "padhv", "padsv");
@{$priv{"entersub"}}{16,32,64} = ("DBG","TARG","NOMOD");
@{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv");
$priv{"gv"}{32} = "EARLYCV";
$priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER";
$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv",
	"enteriter");
$priv{$_}{16} = "TARGMY"
  for (map(($_,"s$_"),"chop", "chomp"),
       map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo",
	   "add", "subtract", "negate"), "pow", "concat", "stringify",
       "left_shift", "right_shift", "bit_and", "bit_xor", "bit_or",
       "complement", "atan2", "sin", "cos", "rand", "exp", "log", "sqrt",
       "int", "hex", "oct", "abs", "length", "index", "rindex", "sprintf",
       "ord", "chr", "crypt", "quotemeta", "join", "push", "unshift", "flock",
       "chdir", "chown", "chroot", "unlink", "chmod", "utime", "rename",
       "link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system",
       "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority",
       "setpriority", "time", "sleep");
$priv{$_}{4} = "REVERSED" for ("enteriter", "iter");
@{$priv{"const"}}{4,8,16,32,64,128} = ("SHORT","STRICT","ENTERED",'$[',"BARE","WARN");
$priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM";
$priv{"list"}{64} = "GUESSED";
$priv{"delete"}{64} = "SLICE";
$priv{"exists"}{64} = "SUB";
@{$priv{"sort"}}{1,2,4,8,16,32,64} = ("NUM", "INT", "REV", "INPLACE","DESC","QSORT","STABLE");
$priv{"threadsv"}{64} = "SVREFd";
@{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR")
  for ("open", "backtick");
$priv{"exit"}{128} = "VMS";
$priv{$_}{2} = "FTACCESS"
  for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec");
$priv{"entereval"}{2} = "HAS_HH";
if ($] >= 5.009) {
  # Stacked filetests are post 5.8.x
  $priv{$_}{4} = "FTSTACKED"
    for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec",
         "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime",
	 "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir",
	 "ftpipe", "ftlink", "ftsuid", "ftsgid", "ftsvtx", "fttty", "fttext",
	 "ftbinary");
  # Lexical $_ is post 5.8.x
  $priv{$_}{2} = "GREPLEX"
    for ("mapwhile", "mapstart", "grepwhile", "grepstart");
}

our %hints; # used to display each COP's op_hints values

# strict refs, subs, vars
@hints{2,512,1024} = ('$', '&', '*');
# integers, locale, bytes, arybase
@hints{1,4,8,16,32} = ('i', 'l', 'b', '[');
# block scope, localise %^H, $^OPEN (in), $^OPEN (out)
@hints{256,131072,262144,524288} = ('{','%','<','>');
# overload new integer, float, binary, string, re
@hints{4096,8192,16384,32768,65536} = ('I', 'F', 'B', 'S', 'R');
# taint and eval
@hints{1048576,2097152} = ('T', 'E');
# filetest access, UTF-8
@hints{4194304,8388608} = ('X', 'U');

sub _flags {
    my($hash, $x) = @_;
    my @s;
    for my $flag (sort {$b <=> $a} keys %$hash) {
	if ($hash->{$flag} and $x & $flag and $x >= $flag) {
	    $x -= $flag;
	    push @s, $hash->{$flag};
	}
    }
    push @s, $x if $x;
    return join(",", @s);
}

sub private_flags {
    my($name, $x) = @_;
    _flags($priv{$name}, $x);
}

sub hints_flags {
    my($x) = @_;
    _flags(\%hints, $x);
}

sub concise_sv {
    my($sv, $hr, $preferpv) = @_;
    $hr->{svclass} = class($sv);
    $hr->{svclass} = "UV"
      if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV;
    Carp::cluck("bad concise_sv: $sv") unless $sv and $$sv;
    $hr->{svaddr} = sprintf("%#x", $$sv);
    if ($hr->{svclass} eq "GV" && $sv->isGV_with_GP()) {
	my $gv = $sv;
	my $stash = $gv->STASH->NAME; if ($stash eq "main") {
	    $stash = "";
	} else {
	    $stash = $stash . "::";
	}
	$hr->{svval} = "*$stash" . $gv->SAFENAME;
	return "*$stash" . $gv->SAFENAME;
    } else {
	while (class($sv) eq "RV") {
	    $hr->{svval} .= "\\";
	    $sv = $sv->RV;
	}
	if (class($sv) eq "SPECIAL") {
	    $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
	} elsif ($preferpv && $sv->FLAGS & SVf_POK) {
	    $hr->{svval} .= cstring($sv->PV);
	} elsif ($sv->FLAGS & SVf_NOK) {
	    $hr->{svval} .= $sv->NV;
	} elsif ($sv->FLAGS & SVf_IOK) {
	    $hr->{svval} .= $sv->int_value;
	} elsif ($sv->FLAGS & SVf_POK) {
	    $hr->{svval} .= cstring($sv->PV);
	} elsif (class($sv) eq "HV") {
	    $hr->{svval} .= 'HASH';
	}

	$hr->{svval} = 'undef' unless defined $hr->{svval};
	my $out = $hr->{svclass};
	return $out .= " $hr->{svval}" ; 
    }
}

my %srclines;

sub fill_srclines {
    my $fullnm = shift;
    if ($fullnm eq '-e') {
	$srclines{$fullnm} = [ $fullnm, "-src not supported for -e" ];
	return;
    }
    open (my $fh, '<', $fullnm)
	or warn "# $fullnm: $!, (chdirs not supported by this feature yet)\n"
	and return;
    my @l = <$fh>;
    chomp @l;
    unshift @l, $fullnm; # like @{_<$fullnm} in debug, array starts at 1
    $srclines{$fullnm} = \@l;
}

sub concise_op {
    my ($op, $level, $format) = @_;
    my %h;
    $h{exname} = $h{name} = $op->name;
    $h{NAME} = uc $h{name};
    $h{class} = class($op);
    $h{extarg} = $h{targ} = $op->targ;
    $h{extarg} = "" unless $h{extarg};
    if ($h{name} eq "null" and $h{targ}) {
	# targ holds the old type
	$h{exname} = "ex-" . substr(ppname($h{targ}), 3);
	$h{extarg} = "";
    } elsif ($op->name =~ /^leave(sub(lv)?|write)?$/) {
	# targ potentially holds a reference count
	if ($op->private & 64) {
	    my $refs = "ref" . ($h{targ} != 1 ? "s" : "");
	    $h{targarglife} = $h{targarg} = "$h{targ} $refs";
	}
    } elsif ($h{targ}) {
	my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}];
	if (defined $padname and class($padname) ne "SPECIAL") {
	    $h{targarg}  = $padname->PVX;
	    if ($padname->FLAGS & SVf_FAKE) {
		if ($] < 5.009) {
		    $h{targarglife} = "$h{targarg}:FAKE";
		} else {
		    # These changes relate to the jumbo closure fix.
		    # See changes 19939 and 20005
		    my $fake = '';
		    $fake .= 'a'
		   	if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON;
		    $fake .= 'm'
		   	if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI;
		    $fake .= ':' . $padname->PARENT_PAD_INDEX
			if $curcv->CvFLAGS & CVf_ANON;
		    $h{targarglife} = "$h{targarg}:FAKE:$fake";
		}
	    }
	    else {
		my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base;
		my $finish = int($padname->COP_SEQ_RANGE_HIGH) - $cop_seq_base;
		$finish = "end" if $finish == 999999999 - $cop_seq_base;
		$h{targarglife} = "$h{targarg}:$intro,$finish";
	    }
	} else {
	    $h{targarglife} = $h{targarg} = "t" . $h{targ};
	}
    }
    $h{arg} = "";
    $h{svclass} = $h{svaddr} = $h{svval} = "";
    if ($h{class} eq "PMOP") {
	my $precomp = $op->precomp;
	if (defined $precomp) {
	    $precomp = cstring($precomp); # Escape literal control sequences
 	    $precomp = "/$precomp/";
	} else {
	    $precomp = "";
	}
	my $pmreplroot = $op->pmreplroot;
	my $pmreplstart;
	if (ref($pmreplroot) eq "B::GV") {
	    # with C<@stash_array = split(/pat/, str);>,
	    #  *stash_array is stored in /pat/'s pmreplroot.
	    $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
	} elsif (!ref($pmreplroot) and $pmreplroot) {
	    # same as the last case, except the value is actually a
	    # pad offset for where the GV is kept (this happens under
	    # ithreads)
	    my $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$pmreplroot];
	    $h{arg} = "($precomp => \@" . $gv->NAME . ")";
	} elsif ($ {$op->pmreplstart}) {
	    undef $lastnext;
	    $pmreplstart = "replstart->" . seq($op->pmreplstart);
	    $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")";
	} else {
	    $h{arg} = "($precomp)";
	}
    } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") {
	$h{arg} = '("' . $op->pv . '")';
	$h{svval} = '"' . $op->pv . '"';
    } elsif ($h{class} eq "COP") {
	my $label = $op->label;
	$h{coplabel} = $label;
	$label = $label ? "$label: " : "";
	my $loc = $op->file;
	my $pathnm = $loc;
	$loc =~ s[.*/][];
	my $ln = $op->line;
	$loc .= ":$ln";
	my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
	my $arybase = $op->arybase;
	$arybase = $arybase ? ' $[=' . $arybase : "";
	$h{arg} = "($label$stash $cseq $loc$arybase)";
	if ($show_src) {
	    fill_srclines($pathnm) unless exists $srclines{$pathnm};
	    # Would love to retain Jim's use of // but this code needs to be
	    # portable to 5.8.x
	    my $line = $srclines{$pathnm}[$ln];
	    $line = "-src unavailable under -e" unless defined $line;
	    $h{src} = "$ln: $line";
	}
    } elsif ($h{class} eq "LOOP") {
	$h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop)
	  . " redo->" . seq($op->redoop) . ")";
    } elsif ($h{class} eq "LOGOP") {
	undef $lastnext;
	$h{arg} = "(other->" . seq($op->other) . ")";
    }
    elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") {
	unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {
	    my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix;
	    my $preferpv = $h{name} eq "method_named";
	    if ($h{class} eq "PADOP" or !${$op->sv}) {
		my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx];
		$h{arg} = "[" . concise_sv($sv, \%h, $preferpv) . "]";
		$h{targarglife} = $h{targarg} = "";
	    } else {
		$h{arg} = "(" . concise_sv($op->sv, \%h, $preferpv) . ")";
	    }
	}
    }
    $h{seq} = $h{hyphseq} = seq($op);
    $h{seq} = "" if $h{seq} eq "-";
    if ($] > 5.009) {
	$h{opt} = $op->opt;
	$h{label} = $labels{$$op};
    } else {
	$h{seqnum} = $op->seq;
	$h{label} = $labels{$op->seq};
    }
    $h{next} = $op->next;
    $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
    $h{nextaddr} = sprintf("%#x", $ {$op->next});
    $h{sibaddr} = sprintf("%#x", $ {$op->sibling});
    $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first");
    $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last");

    $h{classsym} = $opclass{$h{class}};
    $h{flagval} = $op->flags;
    $h{flags} = op_flags($op->flags);
    $h{privval} = $op->private;
    $h{private} = private_flags($h{name}, $op->private);
    if ($op->can("hints")) {
      $h{hintsval} = $op->hints;
      $h{hints} = hints_flags($h{hintsval});
    } else {
      $h{hintsval} = $h{hints} = '';
    }
    $h{addr} = sprintf("%#x", $$op);
    $h{typenum} = $op->type;
    $h{noise} = $linenoise[$op->type];

    return fmt_line(\%h, $op, $format, $level);
}

sub B::OP::concise {
    my($op, $level) = @_;
    if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
	# insert a 'goto' line
	my $synth = {"seq" => seq($lastnext), "class" => class($lastnext),
		     "addr" => sprintf("%#x", $$lastnext),
		     "goto" => seq($lastnext), # simplify goto '-' removal
	     };
	print $walkHandle fmt_line($synth, $op, $gotofmt, $level+1);
    }
    $lastnext = $op->next;
    print $walkHandle concise_op($op, $level, $format);
}