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