1package Opcodes; 2 3use 5.006_001; 4use strict; 5 6our($VERSION, @ISA, @EXPORT, @EXPORT_OK); 7 8$VERSION = "0.14"; 9 10use Exporter (); 11use XSLoader (); 12 13BEGIN { 14 @ISA = qw(Exporter); 15 @EXPORT = 16 qw(opcodes opname opname2code opflags opaliases 17 opargs opclass opdesc opname 18 OA_CLASS_MASK 19 OA_MARK 20 OA_FOLDCONST 21 OA_RETSCALAR 22 OA_TARGET 23 OA_RETINTEGER 24 OA_OTHERINT 25 OA_DANGEROUS 26 OA_DEFGV 27 OA_TARGLEX 28 29 OA_BASEOP 30 OA_UNOP 31 OA_BINOP 32 OA_LOGOP 33 OA_LISTOP 34 OA_PMOP 35 OA_SVOP 36 OA_PADOP 37 OA_PVOP_OR_SVOP 38 OA_LOOP 39 OA_COP 40 OA_BASEOP_OR_UNOP 41 OA_FILESTATOP 42 OA_LOOPEXOP 43 44 OA_SCALAR 45 OA_LIST 46 OA_AVREF 47 OA_HVREF 48 OA_CVREF 49 OA_FILEREF 50 OA_SCALARREF 51 OA_OPTIONAL 52 53 OA_NOSTACK 54 OA_MAYSCALAR 55 OA_MAYARRAY 56 OA_MAYVOID 57 OA_RETFIXED 58 OA_MAYBRANCH 59 ); 60 @EXPORT_OK = qw(ppaddr check argnum maybranch); 61} 62use subs @EXPORT_OK; 63 64sub AUTOLOAD { 65 # 'autoload' constants from the constant() XS function. 66 my $constname; 67 our $AUTOLOAD; 68 ($constname = $AUTOLOAD) =~ s/.*:://; 69 die "&Opcodes::constant not defined" if $constname eq 'constant'; 70 my ($error, $val) = constant($constname); 71 if ($error) { die $error; } 72 { 73 no strict 'refs'; 74 *$AUTOLOAD = sub { $val }; 75 } 76 goto &$AUTOLOAD; 77} 78 79XSLoader::load 'Opcodes', $VERSION; 80 81our @opcodes = opcodes(); 82 83sub opname ($) { 84 $opcodes[ $_[0] ]->[1]; 85} 86 87sub ppaddr ($) { 88 $opcodes[ $_[0] ]->[2]; 89} 90 91sub check ($) { 92 $opcodes[ $_[0] ]->[3]; 93} 94 95sub opdesc ($) { 96 Opcode::opdesc( opname( $_[0] )); 97} 98 99sub opargs ($) { 100 $opcodes[ $_[0] ]->[4]; 101} 102 103# n no_stack - A handcoded list of ops without any SP handling (Note: stack_base is allowed), 104# i.e. no args + no return values. 105# 'n' 512 is not encoded in opcode.pl. We could add it but then we would have to 106# maintain it in CORE as well as here. Here its is needed for older perls. So 107# keep it this way. Note that enter,entertry,leave indirectly use the stack. 108our %no_stack = map{$_=>1}qw[null unstack scope lineseq 109 next redo goto break continue nextstate dbstate pushmark 110 regcmaybe regcreset]; 111# S retval may be scalar. s and i are automatically included 112our %retval_scalar = map{$_=>1}qw[]; 113# A retval may be array 114our %retval_array = map{$_=>1}qw[]; 115# V retval may be void 116our %retval_void = map{$_=>1}qw[]; 117# F fixed retval type (S, A or V) 118our %retval_fixed = map{$_=>1}qw[]; 119# N pp_* may return other than op_next 120our %maybranch = map{$_=>1} 121 # LOGOP's which return op_other 122 qw[once cond_expr and or orassign andassign dor dorassign grepwhile mapwhile substcont 123 enterwhen entergiven range 124 ], 125 # other OPs 126 qw[formline grepstart flip dbstate goto leaveeval 127 break 128 subst entersub 129 return last next redo require entereval entertry continue dump 130 ]; 131 132sub opflags ($) { 133 # 0x1ff = 9 bits OCSHIFT 134 my $OCSHIFT = constant('OCSHIFT'); # 9 135 my $mask = (2 ** $OCSHIFT) - 1; 136 my $flags = opargs($_[0]) & $mask; # & 0x1ff 137 # now the extras 138 my $opname = opname($_[0]); 139 #$flags += 16 if $retint{$opname}; 140 $flags += 512 if $no_stack{$opname}; 141 $flags += 1024 if $retval_scalar{$opname} or $flags & 20; # 4|16 142 $flags += 2048 if $retval_array{$opname}; 143 $flags += 4096 if $retval_void{$opname}; 144 $flags += 8192 if $retval_fixed{$opname}; 145 $flags += 16384 if maybranch($_[0]); 146 return $flags; 147} 148 149# See F<opcode.pl> for $OASHIFT and $OCSHIFT. For flags n 512 we 150# would have to change that. 151sub opclass ($) { 152 my $OCSHIFT = constant('OCSHIFT'); # 9 153 my $OASHIFT = constant('OASHIFT'); # 13 154 my $mask = (2 ** ($OASHIFT-$OCSHIFT)) - 1; # 0b1111 4bit 13-9=4 bits 155 $mask = $mask << $OCSHIFT; # 1e00: 4bit left-shifted by 9 156 (opargs($_[0]) & $mask) >> $OCSHIFT; 157} 158 159sub argnum ($) { 160 #my $ARGSHIFT = 4; 161 #my $ARGBITS = 32; 162 my $OASHIFT = constant('OASHIFT'); # 13 163 # ffffe000 = 32-13 bits left-shifted by 13 164 my $mask = ((2 ** (32-$OASHIFT)) - 1) << $OASHIFT; 165 (opargs($_[0]) & $mask) >> $OASHIFT; 166} 167 168sub opaliases ($) { 169 my $op = shift; 170 my @aliases = (); 171 my $ppaddr = ppaddr($op); 172 for (@opcodes) { 173 push @aliases, ($_->[0]) 174 if $_->[2] == $ppaddr and $_->[0] != $op; 175 } 176 @aliases; 177} 178 179sub opname2code ($) { 180 my $name = shift; 181 for (0..$#opcodes) { return $_ if opname($_) eq $name; } 182 return undef; 183} 184 185# All LOGOPs: perl -Mblib -MOpcodes -e'$,=q( );print map {opname $_} grep {opclass($_) == 3} 1..opcodes' => 186# regcomp substcont grepwhile mapwhile range and or dor cond_expr andassign orassign dorassign entergiven 187# enterwhen entertry once 188# All pp which can return other then op_next (inspected pp*.c): 189# once and cond_expr or defined grepwhile 190# substcont formline grepstart mapwhile range flip dbstate goto leaveeval enterwhen break subst entersub 191# return last next redo require entereval entertry continue 192# + aliases: maybranch perl -MOpcodes -e'$,=q( );print map {opname $_} grep {opflags($_) & 16384} 1..opcodes' 193# => subst substcont defined formline grepstart grepwhile mapwhile range and or dor cond_expr andassign 194# orassign dorassign dbstate return last next redo dump goto entergiven enterwhen require entereval 195# entertry once 196sub maybranch ($) { 197 return undef if opclass($_[0]) <= 2; # NOT if lower than LOGOP 198 my $opname = opname($_[0]); 199 return 1 if $maybranch{$opname}; 200 for (opaliases($_[0])) { 201 return 1 if $maybranch{opname($_)}; 202 } 203 return undef; 204} 205 206 2071; 208__END__ 209 210=head1 NAME 211 212Opcodes - More Opcodes information from opnames.h and opcode.h 213 214=head1 SYNOPSIS 215 216 use Opcodes; 217 print "Empty opcodes are null and ", 218 join ",", map {opname $_}, opaliases(opname2code('null')); 219 220 # All LOGOPs 221 perl -MOpcodes -e'$,=q( );print map {opname $_} grep {opclass($_) == 2} 1..opcodes' 222 223 # Ops which can return other than op->next 224 perl -MOpcodes -e'$,=q( );print map {opname $_} grep {Opcodes::maybranch $_} 1..opcodes' 225 226 227=head1 DESCRIPTION 228 229=head1 Operator Names and Operator Lists 230 231The canonical list of operator names is the contents of the array 232PL_op_name, defined and initialised in file F<opcode.h> of the Perl 233source distribution (and installed into the perl library). 234 235Each operator has both a terse name (its opname) and a more verbose or 236recognisable descriptive name. The opdesc function can be used to 237return a the description for an OP. 238 239=over 8 240 241=item an operator name (opname) 242 243Operator names are typically small lowercase words like enterloop, 244leaveloop, last, next, redo etc. Sometimes they are rather cryptic 245like gv2cv, i_ncmp and ftsvtx. 246 247=item an OP opcode 248 249The opcode information functions all take the integer code, 0..MAX0, 250MAXO being accessed by scalar @opcodes, the length of 251the opcodes array. 252 253=back 254 255 256=head1 Opcode Information 257 258Retrieve information of the Opcodes. All are available for export by the package. 259Functions names starting with "op" are automatically exported. 260 261=over 8 262 263=item opcodes 264 265In a scalar context opcodes returns the number of opcodes in this 266version of perl (361 with perl-5.10). 267 268In a list context it returns a list of all the operators with 269its properties, a list of [ opcode opname ppaddr check opargs ]. 270 271=item opname (OP) 272 273Returns the lowercase name without pp_ for the OP, 274an integer between 0 and MAXO. 275 276=item ppaddr (OP) 277 278Returns the address of the ppaddr, which can be used to 279get the aliases for each opcode. 280 281=item check (OP) 282 283Returns the address of the check function. 284 285=item opdesc (OP) 286 287Returns the string description of the OP. 288 289=item opargs (OP) 290 291Returns the opcode args encoded as integer of the opcode. 292See below or F<opcode.pl> for the encoding details. 293 294 opflags 1-128 + opclass 1-13 << 9 + argnum 1-15.. << 13 295 296=item argnum (OP) 297 298Returns the arguments and types encoded as number acccording 299to the following table, 4 bit for each argument. 300 301 'S', 1, # scalar 302 'L', 2, # list 303 'A', 3, # array value 304 'H', 4, # hash value 305 'C', 5, # code value 306 'F', 6, # file value 307 'R', 7, # scalar reference 308 309 + '?', 8, # optional 310 311Example: 312 313 argnum(opname2code('bless')) => 145 314 145 = 0b10010001 => S S? 315 316 first 4 bits 0001 => 1st arg is a Scalar, 317 next 4 bits 1001 => (bit 8+1) 2nd arg is an optional Scalar 318 319=item opclass (OP) 320 321Returns the op class as number according to the following table 322from F<opcode.pl>: 323 324 '0', 0, # baseop 325 '1', 1, # unop 326 '2', 2, # binop 327 '|', 3, # logop 328 '@', 4, # listop 329 '/', 5, # pmop 330 '$', 6, # svop_or_padop 331 '#', 7, # padop 332 '"', 8, # pvop_or_svop 333 '{', 9, # loop 334 ';', 10, # cop 335 '%', 11, # baseop_or_unop 336 '-', 12, # filestatop 337 '}', 13, # loopexop 338 339=item opflags (OP) 340 341Returns op flags as number according to the following table 342from F<opcode.pl>. In doubt see your perl source. 343I<Warning: There is currently an attempt to change that, but I posted a fix> 344 345 'm' => OA_MARK, # needs stack mark 346 'f' => OA_FOLDCONST, # fold constants 347 's' => OA_RETSCALAR, # always produces scalar 348 't' => OA_TARGET, # needs target scalar 349 'T' => OA_TARGET | OA_TARGLEX, # ... which may be lexical 350 'i' => OA_RETINTEGER, # always produces integer (this bit is in question) 351 'I' => OA_OTHERINT, # has corresponding int op 352 'd' => OA_DANGEROUS, # danger, unknown side effects 353 'u' => OA_DEFGV, # defaults to $_ 354 355plus not from F<opcode.pl>: 356 357 'n' => OA_NOSTACK, # nothing on the stack, no args and return 358 'N' => OA_MAYBRANCH # No next. may return other than PL_op->op_next, maybranch 359 360These not yet: 361 362 'S' => OA_MAYSCALAR # retval may be scalar 363 'A' => OA_MAYARRAY # retval may be array 364 'V' => OA_MAYVOID # retval may be void 365 'F' => OA_RETFIXED # fixed retval type, either S or A or V 366 367=item OA_* constants 368 369All OA_ flag, class and argnum constants from F<op.h> are exported. 370Addionally new OA_ flags have been created which are needed for L<B::CC>. 371 372=item opaliases (OP) 373 374Returns the opcodes for the aliased opcode functions for the given OP, the ops 375with the same ppaddr. 376 377=item opname2code (OPNAME) 378 379Does a reverse lookup in the opcodes list to get the opcode for the given 380name. 381 382=item maybranch (OP) 383 384Returns if the OP function may return not op->op_next. 385 386Note that not all OP classes which have op->op_other, op->op_first or op->op_last 387(higher then UNOP) are actually returning an other next op than op->op_next. 388 389 opflags(OP) & 16384 390 391=back 392 393=head1 SEE ALSO 394 395L<Opcode> -- The Perl CORE Opcode module for handling sets of Opcodes used by L<Safe>. 396 397L<Safe> -- Opcode and namespace limited execution compartments 398 399L<B::CC> -- The optimizing perl compiler uses this module. L<Jit> also, 400 but only the static information 401 402=head1 TEST REPORTS 403 404CPAN Testers: L<http://cpantesters.org/distro/O/Opcodes> 405 406Travis: L<https://travis-ci.org/rurban/Opcodes.png|https://travis-ci.org/rurban/Opcodes/> 407 408Coveralls: L<https://coveralls.io/repos/rurban/Opcodes/badge.png|https://coveralls.io/r/rurban/Opcodes?branch=master> 409 410=head1 AUTHOR 411 412Reini Urban C<rurban@cpan.org> 2010, 2014 413 414=head1 LICENSE 415 416Copyright 1995, Malcom Beattie. 417Copyright 1996, Tim Bunce. 418Copyright 2010, 2014 Reini Urban. 419All rights reserved. 420 421This program is free software; you can redistribute it and/or 422modify it under the same terms as Perl itself. 423 424=cut 425 426# Local Variables: 427# mode: cperl 428# cperl-indent-level: 4 429# fill-column: 78 430# End: 431# vim: expandtab shiftwidth=4: 432
