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