Recoving dup tests for VMS
[p5sagit/p5-mst-13.2.git] / ext / B / B.pm
CommitLineData
a798dbf2 1# B.pm
2#
1a52ab62 3# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
a798dbf2 4#
5# You may distribute under the terms of either the GNU General Public
6# License or the Artistic License, as specified in the README file.
7#
8package B;
9426adcd 9use XSLoader ();
a798dbf2 10require Exporter;
9426adcd 11@ISA = qw(Exporter);
b2590c4e 12
f72d64f0 13# walkoptree_slow comes from B.pm (you are there),
14# walkoptree comes from B.xs
f6c2d85b 15@EXPORT_OK = qw(minus_c ppname save_BEGINs
16 class peekop cast_I32 cstring cchar hash threadsv_names
b2590c4e 17 main_root main_start main_cv svref_2object opnumber
18 amagic_generation
f6c2d85b 19 walkoptree_slow walkoptree walkoptree_exec walksymtable
20 parents comppadlist sv_undef compile_stats timing_info
21 begin_av init_av end_av);
b2590c4e 22
4c1f658f 23sub OPf_KIDS ();
a798dbf2 24use strict;
25@B::SV::ISA = 'B::OBJECT';
26@B::NULL::ISA = 'B::SV';
27@B::PV::ISA = 'B::SV';
28@B::IV::ISA = 'B::SV';
29@B::NV::ISA = 'B::IV';
30@B::RV::ISA = 'B::SV';
31@B::PVIV::ISA = qw(B::PV B::IV);
32@B::PVNV::ISA = qw(B::PV B::NV);
33@B::PVMG::ISA = 'B::PVNV';
34@B::PVLV::ISA = 'B::PVMG';
35@B::BM::ISA = 'B::PVMG';
36@B::AV::ISA = 'B::PVMG';
37@B::GV::ISA = 'B::PVMG';
38@B::HV::ISA = 'B::PVMG';
39@B::CV::ISA = 'B::PVMG';
276493cb 40@B::IO::ISA = 'B::PVMG';
41@B::FM::ISA = 'B::CV';
a798dbf2 42
43@B::OP::ISA = 'B::OBJECT';
44@B::UNOP::ISA = 'B::OP';
45@B::BINOP::ISA = 'B::UNOP';
46@B::LOGOP::ISA = 'B::UNOP';
a798dbf2 47@B::LISTOP::ISA = 'B::BINOP';
48@B::SVOP::ISA = 'B::OP';
7934575e 49@B::PADOP::ISA = 'B::OP';
a798dbf2 50@B::PVOP::ISA = 'B::OP';
51@B::CVOP::ISA = 'B::OP';
52@B::LOOP::ISA = 'B::LISTOP';
53@B::PMOP::ISA = 'B::LISTOP';
54@B::COP::ISA = 'B::OP';
55
56@B::SPECIAL::ISA = 'B::OBJECT';
57
58{
59 # Stop "-w" from complaining about the lack of a real B::OBJECT class
60 package B::OBJECT;
61}
62
002b978b 63sub B::GV::SAFENAME {
64 my $name = (shift())->NAME;
d9963e60 65
66 # The regex below corresponds to the isCONTROLVAR macro
67 # from toke.c
68
7a9b44b9 69 $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".
70 chr( utf8::unicode_to_native( 64 ^ ord($1) ))/e;
71
72 # When we say unicode_to_native we really mean ascii_to_native,
73 # which matters iff this is a non-ASCII platform (EBCDIC).
74
002b978b 75 return $name;
76}
77
d9963e60 78sub B::IV::int_value {
79 my ($self) = @_;
80 return (($self->FLAGS() & SVf_IVisUV()) ? $self->UVX : $self->IV);
81}
82
f3402b25 83sub B::NULL::as_string() {""}
84sub B::IV::as_string() {goto &B::IV::int_value}
85sub B::PV::as_string() {goto &B::PV::PV}
86
a798dbf2 87my $debug;
88my $op_count = 0;
89my @parents = ();
90
91sub debug {
92 my ($class, $value) = @_;
93 $debug = $value;
94 walkoptree_debug($value);
95}
96
a798dbf2 97sub class {
98 my $obj = shift;
99 my $name = ref $obj;
100 $name =~ s/^.*:://;
101 return $name;
102}
103
104sub parents { \@parents }
105
106# For debugging
107sub peekop {
108 my $op = shift;
3f872cb9 109 return sprintf("%s (0x%x) %s", class($op), $$op, $op->name);
a798dbf2 110}
111
b2590c4e 112sub walkoptree_slow {
a798dbf2 113 my($op, $method, $level) = @_;
114 $op_count++; # just for statistics
115 $level ||= 0;
116 warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
117 $op->$method($level);
118 if ($$op && ($op->flags & OPf_KIDS)) {
119 my $kid;
120 unshift(@parents, $op);
121 for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
b2590c4e 122 walkoptree_slow($kid, $method, $level + 1);
a798dbf2 123 }
124 shift @parents;
125 }
126}
127
128sub compile_stats {
129 return "Total number of OPs processed: $op_count\n";
130}
131
132sub timing_info {
133 my ($sec, $min, $hr) = localtime;
134 my ($user, $sys) = times;
135 sprintf("%02d:%02d:%02d user=$user sys=$sys",
136 $hr, $min, $sec, $user, $sys);
137}
138
139my %symtable;
2b8dc4d2 140
141sub clearsym {
142 %symtable = ();
143}
144
a798dbf2 145sub savesym {
146 my ($obj, $value) = @_;
147# warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
148 $symtable{sprintf("sym_%x", $$obj)} = $value;
149}
150
151sub objsym {
152 my $obj = shift;
153 return $symtable{sprintf("sym_%x", $$obj)};
154}
155
156sub walkoptree_exec {
157 my ($op, $method, $level) = @_;
244826eb 158 $level ||= 0;
a798dbf2 159 my ($sym, $ppname);
160 my $prefix = " " x $level;
161 for (; $$op; $op = $op->next) {
162 $sym = objsym($op);
163 if (defined($sym)) {
164 print $prefix, "goto $sym\n";
165 return;
166 }
167 savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
168 $op->$method($level);
3f872cb9 169 $ppname = $op->name;
1a67a97c 170 if ($ppname =~
3f872cb9 171 /^(or|and|mapwhile|grepwhile|entertry|range|cond_expr)$/)
1a67a97c 172 {
a798dbf2 173 print $prefix, uc($1), " => {\n";
174 walkoptree_exec($op->other, $method, $level + 1);
175 print $prefix, "}\n";
3f872cb9 176 } elsif ($ppname eq "match" || $ppname eq "subst") {
a798dbf2 177 my $pmreplstart = $op->pmreplstart;
178 if ($$pmreplstart) {
179 print $prefix, "PMREPLSTART => {\n";
180 walkoptree_exec($pmreplstart, $method, $level + 1);
181 print $prefix, "}\n";
182 }
3f872cb9 183 } elsif ($ppname eq "substcont") {
a798dbf2 184 print $prefix, "SUBSTCONT => {\n";
185 walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
186 print $prefix, "}\n";
187 $op = $op->other;
3f872cb9 188 } elsif ($ppname eq "enterloop") {
a798dbf2 189 print $prefix, "REDO => {\n";
190 walkoptree_exec($op->redoop, $method, $level + 1);
191 print $prefix, "}\n", $prefix, "NEXT => {\n";
192 walkoptree_exec($op->nextop, $method, $level + 1);
193 print $prefix, "}\n", $prefix, "LAST => {\n";
194 walkoptree_exec($op->lastop, $method, $level + 1);
195 print $prefix, "}\n";
3f872cb9 196 } elsif ($ppname eq "subst") {
a798dbf2 197 my $replstart = $op->pmreplstart;
198 if ($$replstart) {
199 print $prefix, "SUBST => {\n";
200 walkoptree_exec($replstart, $method, $level + 1);
201 print $prefix, "}\n";
202 }
203 }
204 }
205}
206
207sub walksymtable {
208 my ($symref, $method, $recurse, $prefix) = @_;
209 my $sym;
0cc1d052 210 my $ref;
a798dbf2 211 no strict 'vars';
212 local(*glob);
0cc1d052 213 $prefix = '' unless defined $prefix;
214 while (($sym, $ref) = each %$symref) {
8bac7e00 215 *glob = "*main::".$prefix.$sym;
a798dbf2 216 if ($sym =~ /::$/) {
217 $sym = $prefix . $sym;
b4e94495 218 if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) {
a798dbf2 219 walksymtable(\%glob, $method, $recurse, $sym);
220 }
221 } else {
222 svref_2object(\*glob)->EGV->$method();
223 }
224 }
225}
226
227{
228 package B::Section;
229 my $output_fh;
230 my %sections;
231
232 sub new {
233 my ($class, $section, $symtable, $default) = @_;
234 $output_fh ||= FileHandle->new_tmpfile;
235 my $obj = bless [-1, $section, $symtable, $default], $class;
236 $sections{$section} = $obj;
237 return $obj;
238 }
239
240 sub get {
241 my ($class, $section) = @_;
242 return $sections{$section};
243 }
244
245 sub add {
246 my $section = shift;
247 while (defined($_ = shift)) {
248 print $output_fh "$section->[1]\t$_\n";
249 $section->[0]++;
250 }
251 }
252
253 sub index {
254 my $section = shift;
255 return $section->[0];
256 }
257
258 sub name {
259 my $section = shift;
260 return $section->[1];
261 }
262
263 sub symtable {
264 my $section = shift;
265 return $section->[2];
266 }
267
268 sub default {
269 my $section = shift;
270 return $section->[3];
271 }
272
273 sub output {
274 my ($section, $fh, $format) = @_;
275 my $name = $section->name;
276 my $sym = $section->symtable || {};
277 my $default = $section->default;
278
279 seek($output_fh, 0, 0);
280 while (<$output_fh>) {
281 chomp;
282 s/^(.*?)\t//;
283 if ($1 eq $name) {
284 s{(s\\_[0-9a-f]+)} {
285 exists($sym->{$1}) ? $sym->{$1} : $default;
286 }ge;
287 printf $fh $format, $_;
288 }
289 }
290 }
291}
292
9426adcd 293XSLoader::load 'B';
a798dbf2 294
2951;
7f20e9dd 296
297__END__
298
299=head1 NAME
300
301B - The Perl Compiler
302
303=head1 SYNOPSIS
304
305 use B;
306
307=head1 DESCRIPTION
308
1a52ab62 309The C<B> module supplies classes which allow a Perl program to delve
310into its own innards. It is the module used to implement the
311"backends" of the Perl compiler. Usage of the compiler does not
312require knowledge of this module: see the F<O> module for the
313user-visible part. The C<B> module is of use to those who want to
314write new compiler backends. This documentation assumes that the
315reader knows a fair amount about perl's internals including such
316things as SVs, OPs and the internal symbol table and syntax tree
317of a program.
318
319=head1 OVERVIEW OF CLASSES
320
321The C structures used by Perl's internals to hold SV and OP
322information (PVIV, AV, HV, ..., OP, SVOP, UNOP, ...) are modelled on a
323class hierarchy and the C<B> module gives access to them via a true
324object hierarchy. Structure fields which point to other objects
325(whether types of SV or types of OP) are represented by the C<B>
326module as Perl objects of the appropriate class. The bulk of the C<B>
327module is the methods for accessing fields of these structures. Note
328that all access is read-only: you cannot modify the internals by
329using this module.
330
331=head2 SV-RELATED CLASSES
332
333B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV,
334B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in
335the obvious way to the underlying C structures of similar names. The
336inheritance hierarchy mimics the underlying C "inheritance". Access
337methods correspond to the underlying C macros for field access,
338usually with the leading "class indication" prefix removed (Sv, Av,
339Hv, ...). The leading prefix is only left in cases where its removal
340would cause a clash in method name. For example, C<GvREFCNT> stays
341as-is since its abbreviation would clash with the "superclass" method
342C<REFCNT> (corresponding to the C function C<SvREFCNT>).
343
344=head2 B::SV METHODS
345
346=over 4
347
348=item REFCNT
349
350=item FLAGS
351
352=back
353
354=head2 B::IV METHODS
355
356=over 4
357
358=item IV
359
d9963e60 360Returns the value of the IV, I<interpreted as
361a signed integer>. This will be misleading
362if C<FLAGS & SVf_IVisUV>. Perhaps you want the
363C<int_value> method instead?
364
1a52ab62 365=item IVX
366
d9963e60 367=item UVX
368
369=item int_value
370
371This method returns the value of the IV as an integer.
372It differs from C<IV> in that it returns the correct
373value regardless of whether it's stored signed or
374unsigned.
375
1a52ab62 376=item needs64bits
377
378=item packiv
379
380=back
381
382=head2 B::NV METHODS
383
384=over 4
385
386=item NV
387
388=item NVX
389
390=back
391
392=head2 B::RV METHODS
393
394=over 4
395
396=item RV
397
398=back
399
400=head2 B::PV METHODS
401
402=over 4
403
404=item PV
405
76ef7183 406This method is the one you usually want. It constructs a
407string using the length and offset information in the struct:
408for ordinary scalars it will return the string that you'd see
409from Perl, even if it contains null characters.
410
0b40bd6d 411=item PVX
412
76ef7183 413This method is less often useful. It assumes that the string
414stored in the struct is null-terminated, and disregards the
415length information.
416
417It is the appropriate method to use if you need to get the name
418of a lexical variable from a padname array. Lexical variable names
419are always stored with a null terminator, and the length field
420(SvCUR) is overloaded for other purposes and can't be relied on here.
421
1a52ab62 422=back
423
424=head2 B::PVMG METHODS
425
426=over 4
427
428=item MAGIC
429
430=item SvSTASH
431
432=back
433
434=head2 B::MAGIC METHODS
435
436=over 4
437
438=item MOREMAGIC
439
440=item PRIVATE
441
442=item TYPE
443
444=item FLAGS
445
446=item OBJ
447
448=item PTR
449
450=back
451
452=head2 B::PVLV METHODS
453
454=over 4
455
456=item TARGOFF
457
458=item TARGLEN
459
460=item TYPE
461
462=item TARG
463
464=back
465
466=head2 B::BM METHODS
467
468=over 4
469
470=item USEFUL
471
472=item PREVIOUS
473
474=item RARE
475
476=item TABLE
477
478=back
479
480=head2 B::GV METHODS
481
482=over 4
483
87d7fd28 484=item is_empty
485
486This method returns TRUE if the GP field of the GV is NULL.
487
1a52ab62 488=item NAME
489
002b978b 490=item SAFENAME
491
492This method returns the name of the glob, but if the first
493character of the name is a control character, then it converts
494it to ^X first, so that *^G would return "^G" rather than "\cG".
495
496It's useful if you want to print out the name of a variable.
497If you restrict yourself to globs which exist at compile-time
498then the result ought to be unambiguous, because code like
499C<${"^G"} = 1> is compiled as two ops - a constant string and
500a dereference (rv2gv) - so that the glob is created at runtime.
501
502If you're working with globs at runtime, and need to disambiguate
503*^G from *{"^G"}, then you should use the raw NAME method.
504
1a52ab62 505=item STASH
506
507=item SV
508
509=item IO
510
511=item FORM
512
513=item AV
514
515=item HV
516
517=item EGV
518
519=item CV
520
521=item CVGEN
522
523=item LINE
524
b195d487 525=item FILE
526
1a52ab62 527=item FILEGV
528
529=item GvREFCNT
530
531=item FLAGS
532
533=back
534
535=head2 B::IO METHODS
536
537=over 4
538
539=item LINES
540
541=item PAGE
542
543=item PAGE_LEN
544
545=item LINES_LEFT
546
547=item TOP_NAME
548
549=item TOP_GV
550
551=item FMT_NAME
552
553=item FMT_GV
554
555=item BOTTOM_NAME
556
557=item BOTTOM_GV
558
559=item SUBPROCESS
560
561=item IoTYPE
562
563=item IoFLAGS
564
565=back
566
567=head2 B::AV METHODS
568
569=over 4
570
571=item FILL
572
573=item MAX
574
575=item OFF
576
577=item ARRAY
578
579=item AvFLAGS
580
581=back
582
583=head2 B::CV METHODS
584
585=over 4
586
587=item STASH
588
589=item START
590
591=item ROOT
592
593=item GV
594
57843af0 595=item FILE
596
1a52ab62 597=item DEPTH
598
599=item PADLIST
600
601=item OUTSIDE
602
603=item XSUB
604
605=item XSUBANY
606
5cfd8ad4 607=item CvFLAGS
608
de3f1649 609=item const_sv
610
1a52ab62 611=back
612
613=head2 B::HV METHODS
614
615=over 4
616
617=item FILL
618
619=item MAX
620
621=item KEYS
622
623=item RITER
624
625=item NAME
626
627=item PMROOT
628
629=item ARRAY
630
631=back
632
633=head2 OP-RELATED CLASSES
634
1a67a97c 635B::OP, B::UNOP, B::BINOP, B::LOGOP, B::LISTOP, B::PMOP,
7934575e 636B::SVOP, B::PADOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
1a52ab62 637These classes correspond in
638the obvious way to the underlying C structures of similar names. The
639inheritance hierarchy mimics the underlying C "inheritance". Access
640methods correspond to the underlying C structre field names, with the
641leading "class indication" prefix removed (op_).
642
643=head2 B::OP METHODS
644
645=over 4
646
647=item next
648
649=item sibling
650
3f872cb9 651=item name
652
653This returns the op name as a string (e.g. "add", "rv2av").
654
1a52ab62 655=item ppaddr
656
dc333d64 657This returns the function name as a string (e.g. "PL_ppaddr[OP_ADD]",
658"PL_ppaddr[OP_RV2AV]").
1a52ab62 659
660=item desc
661
4369b173 662This returns the op description from the global C PL_op_desc array
1a52ab62 663(e.g. "addition" "array deref").
664
665=item targ
666
667=item type
668
669=item seq
670
671=item flags
672
673=item private
674
675=back
676
677=head2 B::UNOP METHOD
678
679=over 4
680
681=item first
682
683=back
684
685=head2 B::BINOP METHOD
686
687=over 4
688
689=item last
690
691=back
692
693=head2 B::LOGOP METHOD
694
695=over 4
696
697=item other
698
699=back
700
1a52ab62 701=head2 B::LISTOP METHOD
702
703=over 4
704
705=item children
706
707=back
708
709=head2 B::PMOP METHODS
710
711=over 4
712
713=item pmreplroot
714
715=item pmreplstart
716
717=item pmnext
718
719=item pmregexp
720
721=item pmflags
722
723=item pmpermflags
724
725=item precomp
726
727=back
728
729=head2 B::SVOP METHOD
730
731=over 4
732
733=item sv
734
065a1863 735=item gv
736
1a52ab62 737=back
738
7934575e 739=head2 B::PADOP METHOD
1a52ab62 740
741=over 4
742
7934575e 743=item padix
1a52ab62 744
745=back
746
747=head2 B::PVOP METHOD
748
749=over 4
750
751=item pv
752
753=back
754
755=head2 B::LOOP METHODS
756
757=over 4
758
759=item redoop
760
761=item nextop
762
763=item lastop
764
765=back
766
767=head2 B::COP METHODS
768
769=over 4
770
771=item label
772
773=item stash
774
57843af0 775=item file
1a52ab62 776
777=item cop_seq
778
779=item arybase
780
781=item line
782
783=back
784
785=head1 FUNCTIONS EXPORTED BY C<B>
786
787The C<B> module exports a variety of functions: some are simple
788utility functions, others provide a Perl program with a way to
789get an initial "handle" on an internal object.
790
791=over 4
792
793=item main_cv
794
795Return the (faked) CV corresponding to the main part of the Perl
796program.
797
31d7d75a 798=item init_av
799
800Returns the AV object (i.e. in class B::AV) representing INIT blocks.
801
1a52ab62 802=item main_root
803
804Returns the root op (i.e. an object in the appropriate B::OP-derived
805class) of the main part of the Perl program.
806
807=item main_start
808
809Returns the starting op of the main part of the Perl program.
810
811=item comppadlist
812
813Returns the AV object (i.e. in class B::AV) of the global comppadlist.
814
815=item sv_undef
816
817Returns the SV object corresponding to the C variable C<sv_undef>.
818
819=item sv_yes
820
821Returns the SV object corresponding to the C variable C<sv_yes>.
822
823=item sv_no
824
825Returns the SV object corresponding to the C variable C<sv_no>.
826
56eca212 827=item amagic_generation
828
829Returns the SV object corresponding to the C variable C<amagic_generation>.
830
1a52ab62 831=item walkoptree(OP, METHOD)
832
833Does a tree-walk of the syntax tree based at OP and calls METHOD on
834each op it visits. Each node is visited before its children. If
835C<walkoptree_debug> (q.v.) has been called to turn debugging on then
836the method C<walkoptree_debug> is called on each op before METHOD is
837called.
838
839=item walkoptree_debug(DEBUG)
840
841Returns the current debugging flag for C<walkoptree>. If the optional
842DEBUG argument is non-zero, it sets the debugging flag to that. See
843the description of C<walkoptree> above for what the debugging flag
844does.
845
87a42246 846=item walksymtable(SYMREF, METHOD, RECURSE, PREFIX)
1a52ab62 847
848Walk the symbol table starting at SYMREF and call METHOD on each
87a42246 849symbol (a B::GV object) visited. When the walk reaches package
850symbols (such as "Foo::") it invokes RECURSE, passing in the symbol
851name, and only recurses into the package if that sub returns true.
852
853PREFIX is the name of the SYMREF you're walking.
854
855For example...
856
857 # Walk CGI's symbol table calling print_subs on each symbol.
858 # Only recurse into CGI::Util::
859 walksymtable(\%CGI::, 'print_subs', sub { $_[0] eq 'CGI::Util::' },
860 'CGI::');
861
862print_subs() is a B::GV method you have declared.
863
1a52ab62 864
865=item svref_2object(SV)
866
867Takes any Perl variable and turns it into an object in the
868appropriate B::OP-derived or B::SV-derived class. Apart from functions
869such as C<main_root>, this is the primary way to get an initial
d1be9408 870"handle" on an internal perl data structure which can then be followed
1a52ab62 871with the other access methods.
872
873=item ppname(OPNUM)
874
875Return the PP function name (e.g. "pp_add") of op number OPNUM.
876
877=item hash(STR)
878
879Returns a string in the form "0x..." representing the value of the
880internal hash function used by perl on string STR.
881
882=item cast_I32(I)
883
884Casts I to the internal I32 type used by that perl.
885
886
887=item minus_c
888
889Does the equivalent of the C<-c> command-line option. Obviously, this
890is only useful in a BEGIN block or else the flag is set too late.
891
892
893=item cstring(STR)
894
895Returns a double-quote-surrounded escaped version of STR which can
896be used as a string in C source code.
897
898=item class(OBJ)
899
900Returns the class of an object without the part of the classname
901preceding the first "::". This is used to turn "B::UNOP" into
902"UNOP" for example.
903
904=item threadsv_names
905
906In a perl compiled for threads, this returns a list of the special
907per-thread threadsv variables.
908
1a52ab62 909=back
7f20e9dd 910
911=head1 AUTHOR
912
913Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
914
915=cut