From 4fcbc3669aa997848e15198cc9fb856287a6788c Mon Sep 17 00:00:00 2001 From: markm Date: Wed, 9 Sep 1998 07:00:04 +0000 Subject: Initial import of Perl5. The king is dead; long live the king! --- contrib/perl5/ext/B/B.pm | 825 ++++++ contrib/perl5/ext/B/B.xs | 1207 ++++++++ contrib/perl5/ext/B/B/Asmdata.pm | 170 ++ contrib/perl5/ext/B/B/Assembler.pm | 227 ++ contrib/perl5/ext/B/B/Bblock.pm | 162 ++ contrib/perl5/ext/B/B/Bytecode.pm | 908 ++++++ contrib/perl5/ext/B/B/C.pm | 1319 +++++++++ contrib/perl5/ext/B/B/CC.pm | 1734 +++++++++++ contrib/perl5/ext/B/B/Debug.pm | 283 ++ contrib/perl5/ext/B/B/Deparse.pm | 2670 +++++++++++++++++ contrib/perl5/ext/B/B/Disassembler.pm | 164 ++ contrib/perl5/ext/B/B/Lint.pm | 367 +++ contrib/perl5/ext/B/B/Showlex.pm | 80 + contrib/perl5/ext/B/B/Stackobj.pm | 301 ++ contrib/perl5/ext/B/B/Terse.pm | 152 + contrib/perl5/ext/B/B/Xref.pm | 392 +++ contrib/perl5/ext/B/B/assemble | 30 + contrib/perl5/ext/B/B/cc_harness | 12 + contrib/perl5/ext/B/B/disassemble | 22 + contrib/perl5/ext/B/B/makeliblinks | 54 + contrib/perl5/ext/B/Makefile.PL | 46 + contrib/perl5/ext/B/NOTES | 168 ++ contrib/perl5/ext/B/O.pm | 85 + contrib/perl5/ext/B/README | 325 +++ contrib/perl5/ext/B/TESTS | 78 + contrib/perl5/ext/B/Todo | 37 + contrib/perl5/ext/B/byteperl.c | 110 + contrib/perl5/ext/B/ramblings/cc.notes | 32 + contrib/perl5/ext/B/ramblings/curcop.runtime | 39 + contrib/perl5/ext/B/ramblings/flip-flop | 51 + contrib/perl5/ext/B/ramblings/magic | 93 + contrib/perl5/ext/B/ramblings/reg.alloc | 32 + contrib/perl5/ext/B/ramblings/runtime.porting | 350 +++ contrib/perl5/ext/B/typemap | 69 + contrib/perl5/ext/DB_File/Changes | 205 ++ contrib/perl5/ext/DB_File/DB_File.pm | 1695 +++++++++++ contrib/perl5/ext/DB_File/DB_File.xs | 1497 ++++++++++ contrib/perl5/ext/DB_File/DB_File_BS | 6 + contrib/perl5/ext/DB_File/Makefile.PL | 20 + contrib/perl5/ext/DB_File/dbinfo | 96 + contrib/perl5/ext/DB_File/typemap | 41 + contrib/perl5/ext/Data/Dumper/Changes | 160 ++ contrib/perl5/ext/Data/Dumper/Dumper.pm | 963 +++++++ contrib/perl5/ext/Data/Dumper/Dumper.xs | 800 ++++++ contrib/perl5/ext/Data/Dumper/Makefile.PL | 11 + contrib/perl5/ext/Data/Dumper/Todo | 32 + contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL | 729 +++++ contrib/perl5/ext/DynaLoader/Makefile.PL | 29 + contrib/perl5/ext/DynaLoader/README | 53 + contrib/perl5/ext/DynaLoader/dl_aix.xs | 670 +++++ contrib/perl5/ext/DynaLoader/dl_cygwin32.xs | 153 + contrib/perl5/ext/DynaLoader/dl_dld.xs | 175 ++ contrib/perl5/ext/DynaLoader/dl_dlopen.xs | 219 ++ contrib/perl5/ext/DynaLoader/dl_hpux.xs | 157 + contrib/perl5/ext/DynaLoader/dl_mpeix.xs | 128 + contrib/perl5/ext/DynaLoader/dl_next.xs | 303 ++ contrib/perl5/ext/DynaLoader/dl_none.xs | 19 + contrib/perl5/ext/DynaLoader/dl_vms.xs | 356 +++ contrib/perl5/ext/DynaLoader/dlutils.c | 72 + contrib/perl5/ext/Errno/ChangeLog | 50 + contrib/perl5/ext/Errno/Errno_pm.PL | 276 ++ contrib/perl5/ext/Errno/Makefile.PL | 29 + contrib/perl5/ext/Fcntl/Fcntl.pm | 137 + contrib/perl5/ext/Fcntl/Fcntl.xs | 377 +++ contrib/perl5/ext/Fcntl/Makefile.PL | 8 + contrib/perl5/ext/GDBM_File/GDBM_File.pm | 87 + contrib/perl5/ext/GDBM_File/GDBM_File.xs | 243 ++ contrib/perl5/ext/GDBM_File/Makefile.PL | 8 + contrib/perl5/ext/GDBM_File/typemap | 27 + contrib/perl5/ext/IO/IO.pm | 36 + contrib/perl5/ext/IO/IO.xs | 292 ++ contrib/perl5/ext/IO/Makefile.PL | 8 + contrib/perl5/ext/IO/README | 4 + contrib/perl5/ext/IO/lib/IO/File.pm | 167 ++ contrib/perl5/ext/IO/lib/IO/Handle.pm | 539 ++++ contrib/perl5/ext/IO/lib/IO/Pipe.pm | 239 ++ contrib/perl5/ext/IO/lib/IO/Seekable.pm | 68 + contrib/perl5/ext/IO/lib/IO/Select.pm | 371 +++ contrib/perl5/ext/IO/lib/IO/Socket.pm | 728 +++++ contrib/perl5/ext/IPC/SysV/ChangeLog | 28 + contrib/perl5/ext/IPC/SysV/MANIFEST | 10 + contrib/perl5/ext/IPC/SysV/Makefile.PL | 36 + contrib/perl5/ext/IPC/SysV/Msg.pm | 223 ++ contrib/perl5/ext/IPC/SysV/README | 20 + contrib/perl5/ext/IPC/SysV/Semaphore.pm | 297 ++ contrib/perl5/ext/IPC/SysV/SysV.pm | 98 + contrib/perl5/ext/IPC/SysV/SysV.xs | 423 +++ contrib/perl5/ext/IPC/SysV/t/msg.t | 41 + contrib/perl5/ext/IPC/SysV/t/sem.t | 51 + contrib/perl5/ext/NDBM_File/Makefile.PL | 8 + contrib/perl5/ext/NDBM_File/NDBM_File.pm | 40 + contrib/perl5/ext/NDBM_File/NDBM_File.xs | 70 + contrib/perl5/ext/NDBM_File/hints/dec_osf.pl | 2 + contrib/perl5/ext/NDBM_File/hints/dynixptx.pl | 3 + contrib/perl5/ext/NDBM_File/hints/solaris.pl | 3 + contrib/perl5/ext/NDBM_File/hints/svr4.pl | 4 + contrib/perl5/ext/NDBM_File/typemap | 27 + contrib/perl5/ext/ODBM_File/Makefile.PL | 8 + contrib/perl5/ext/ODBM_File/ODBM_File.pm | 35 + contrib/perl5/ext/ODBM_File/ODBM_File.xs | 122 + contrib/perl5/ext/ODBM_File/hints/dec_osf.pl | 9 + contrib/perl5/ext/ODBM_File/hints/hpux.pl | 4 + contrib/perl5/ext/ODBM_File/hints/sco.pl | 4 + contrib/perl5/ext/ODBM_File/hints/solaris.pl | 3 + contrib/perl5/ext/ODBM_File/hints/svr4.pl | 4 + contrib/perl5/ext/ODBM_File/hints/ultrix.pl | 4 + contrib/perl5/ext/ODBM_File/typemap | 25 + contrib/perl5/ext/Opcode/Makefile.PL | 7 + contrib/perl5/ext/Opcode/Opcode.pm | 575 ++++ contrib/perl5/ext/Opcode/Opcode.xs | 468 +++ contrib/perl5/ext/Opcode/Safe.pm | 559 ++++ contrib/perl5/ext/Opcode/ops.pm | 45 + contrib/perl5/ext/POSIX/Makefile.PL | 8 + contrib/perl5/ext/POSIX/POSIX.pm | 926 ++++++ contrib/perl5/ext/POSIX/POSIX.pod | 1729 +++++++++++ contrib/perl5/ext/POSIX/POSIX.xs | 3666 ++++++++++++++++++++++++ contrib/perl5/ext/POSIX/hints/bsdos.pl | 3 + contrib/perl5/ext/POSIX/hints/freebsd.pl | 3 + contrib/perl5/ext/POSIX/hints/linux.pl | 5 + contrib/perl5/ext/POSIX/hints/netbsd.pl | 3 + contrib/perl5/ext/POSIX/hints/next_3.pl | 5 + contrib/perl5/ext/POSIX/hints/openbsd.pl | 3 + contrib/perl5/ext/POSIX/hints/sunos_4.pl | 10 + contrib/perl5/ext/POSIX/typemap | 14 + contrib/perl5/ext/SDBM_File/Makefile.PL | 35 + contrib/perl5/ext/SDBM_File/SDBM_File.pm | 35 + contrib/perl5/ext/SDBM_File/SDBM_File.xs | 71 + contrib/perl5/ext/SDBM_File/sdbm/CHANGES | 18 + contrib/perl5/ext/SDBM_File/sdbm/COMPARE | 88 + contrib/perl5/ext/SDBM_File/sdbm/Makefile.PL | 65 + contrib/perl5/ext/SDBM_File/sdbm/README | 396 +++ contrib/perl5/ext/SDBM_File/sdbm/README.too | 9 + contrib/perl5/ext/SDBM_File/sdbm/biblio | 64 + contrib/perl5/ext/SDBM_File/sdbm/dba.c | 85 + contrib/perl5/ext/SDBM_File/sdbm/dbd.c | 111 + contrib/perl5/ext/SDBM_File/sdbm/dbe.1 | 46 + contrib/perl5/ext/SDBM_File/sdbm/dbe.c | 435 +++ contrib/perl5/ext/SDBM_File/sdbm/dbm.c | 120 + contrib/perl5/ext/SDBM_File/sdbm/dbm.h | 35 + contrib/perl5/ext/SDBM_File/sdbm/dbu.c | 251 ++ contrib/perl5/ext/SDBM_File/sdbm/grind | 9 + contrib/perl5/ext/SDBM_File/sdbm/hash.c | 47 + contrib/perl5/ext/SDBM_File/sdbm/linux.patches | 67 + contrib/perl5/ext/SDBM_File/sdbm/makefile.sdbm | 55 + contrib/perl5/ext/SDBM_File/sdbm/pair.c | 283 ++ contrib/perl5/ext/SDBM_File/sdbm/pair.h | 20 + contrib/perl5/ext/SDBM_File/sdbm/readme.ms | 353 +++ contrib/perl5/ext/SDBM_File/sdbm/sdbm.3 | 290 ++ contrib/perl5/ext/SDBM_File/sdbm/sdbm.c | 492 ++++ contrib/perl5/ext/SDBM_File/sdbm/sdbm.h | 290 ++ contrib/perl5/ext/SDBM_File/sdbm/tune.h | 23 + contrib/perl5/ext/SDBM_File/sdbm/util.c | 47 + contrib/perl5/ext/SDBM_File/typemap | 27 + contrib/perl5/ext/Socket/Makefile.PL | 7 + contrib/perl5/ext/Socket/Socket.pm | 307 ++ contrib/perl5/ext/Socket/Socket.xs | 890 ++++++ contrib/perl5/ext/Thread/Makefile.PL | 7 + contrib/perl5/ext/Thread/Notes | 13 + contrib/perl5/ext/Thread/README | 20 + contrib/perl5/ext/Thread/Thread.pm | 185 ++ contrib/perl5/ext/Thread/Thread.xs | 641 +++++ contrib/perl5/ext/Thread/Thread/Queue.pm | 99 + contrib/perl5/ext/Thread/Thread/Semaphore.pm | 87 + contrib/perl5/ext/Thread/Thread/Signal.pm | 50 + contrib/perl5/ext/Thread/Thread/Specific.pm | 29 + contrib/perl5/ext/Thread/create.t | 17 + contrib/perl5/ext/Thread/die.t | 16 + contrib/perl5/ext/Thread/die2.t | 16 + contrib/perl5/ext/Thread/io.t | 39 + contrib/perl5/ext/Thread/join.t | 11 + contrib/perl5/ext/Thread/join2.t | 12 + contrib/perl5/ext/Thread/list.t | 30 + contrib/perl5/ext/Thread/lock.t | 27 + contrib/perl5/ext/Thread/queue.t | 36 + contrib/perl5/ext/Thread/specific.t | 17 + contrib/perl5/ext/Thread/sync.t | 61 + contrib/perl5/ext/Thread/sync2.t | 69 + contrib/perl5/ext/Thread/typemap | 24 + contrib/perl5/ext/Thread/unsync.t | 37 + contrib/perl5/ext/Thread/unsync2.t | 36 + contrib/perl5/ext/Thread/unsync3.t | 50 + contrib/perl5/ext/Thread/unsync4.t | 38 + contrib/perl5/ext/attrs/Makefile.PL | 7 + contrib/perl5/ext/attrs/attrs.pm | 55 + contrib/perl5/ext/attrs/attrs.xs | 59 + contrib/perl5/ext/re/Makefile.PL | 41 + contrib/perl5/ext/re/hints/mpeix.pl | 3 + contrib/perl5/ext/re/re.pm | 131 + contrib/perl5/ext/re/re.xs | 46 + contrib/perl5/ext/util/make_ext | 141 + contrib/perl5/ext/util/mkbootstrap | 5 + 191 files changed, 41734 insertions(+) create mode 100644 contrib/perl5/ext/B/B.pm create mode 100644 contrib/perl5/ext/B/B.xs create mode 100644 contrib/perl5/ext/B/B/Asmdata.pm create mode 100644 contrib/perl5/ext/B/B/Assembler.pm create mode 100644 contrib/perl5/ext/B/B/Bblock.pm create mode 100644 contrib/perl5/ext/B/B/Bytecode.pm create mode 100644 contrib/perl5/ext/B/B/C.pm create mode 100644 contrib/perl5/ext/B/B/CC.pm create mode 100644 contrib/perl5/ext/B/B/Debug.pm create mode 100644 contrib/perl5/ext/B/B/Deparse.pm create mode 100644 contrib/perl5/ext/B/B/Disassembler.pm create mode 100644 contrib/perl5/ext/B/B/Lint.pm create mode 100644 contrib/perl5/ext/B/B/Showlex.pm create mode 100644 contrib/perl5/ext/B/B/Stackobj.pm create mode 100644 contrib/perl5/ext/B/B/Terse.pm create mode 100644 contrib/perl5/ext/B/B/Xref.pm create mode 100755 contrib/perl5/ext/B/B/assemble create mode 100644 contrib/perl5/ext/B/B/cc_harness create mode 100755 contrib/perl5/ext/B/B/disassemble create mode 100644 contrib/perl5/ext/B/B/makeliblinks create mode 100644 contrib/perl5/ext/B/Makefile.PL create mode 100644 contrib/perl5/ext/B/NOTES create mode 100644 contrib/perl5/ext/B/O.pm create mode 100644 contrib/perl5/ext/B/README create mode 100644 contrib/perl5/ext/B/TESTS create mode 100644 contrib/perl5/ext/B/Todo create mode 100644 contrib/perl5/ext/B/byteperl.c create mode 100644 contrib/perl5/ext/B/ramblings/cc.notes create mode 100644 contrib/perl5/ext/B/ramblings/curcop.runtime create mode 100644 contrib/perl5/ext/B/ramblings/flip-flop create mode 100644 contrib/perl5/ext/B/ramblings/magic create mode 100644 contrib/perl5/ext/B/ramblings/reg.alloc create mode 100644 contrib/perl5/ext/B/ramblings/runtime.porting create mode 100644 contrib/perl5/ext/B/typemap create mode 100644 contrib/perl5/ext/DB_File/Changes create mode 100644 contrib/perl5/ext/DB_File/DB_File.pm create mode 100644 contrib/perl5/ext/DB_File/DB_File.xs create mode 100644 contrib/perl5/ext/DB_File/DB_File_BS create mode 100644 contrib/perl5/ext/DB_File/Makefile.PL create mode 100644 contrib/perl5/ext/DB_File/dbinfo create mode 100644 contrib/perl5/ext/DB_File/typemap create mode 100644 contrib/perl5/ext/Data/Dumper/Changes create mode 100644 contrib/perl5/ext/Data/Dumper/Dumper.pm create mode 100644 contrib/perl5/ext/Data/Dumper/Dumper.xs create mode 100644 contrib/perl5/ext/Data/Dumper/Makefile.PL create mode 100644 contrib/perl5/ext/Data/Dumper/Todo create mode 100644 contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL create mode 100644 contrib/perl5/ext/DynaLoader/Makefile.PL create mode 100644 contrib/perl5/ext/DynaLoader/README create mode 100644 contrib/perl5/ext/DynaLoader/dl_aix.xs create mode 100644 contrib/perl5/ext/DynaLoader/dl_cygwin32.xs create mode 100644 contrib/perl5/ext/DynaLoader/dl_dld.xs create mode 100644 contrib/perl5/ext/DynaLoader/dl_dlopen.xs create mode 100644 contrib/perl5/ext/DynaLoader/dl_hpux.xs create mode 100644 contrib/perl5/ext/DynaLoader/dl_mpeix.xs create mode 100644 contrib/perl5/ext/DynaLoader/dl_next.xs create mode 100644 contrib/perl5/ext/DynaLoader/dl_none.xs create mode 100644 contrib/perl5/ext/DynaLoader/dl_vms.xs create mode 100644 contrib/perl5/ext/DynaLoader/dlutils.c create mode 100644 contrib/perl5/ext/Errno/ChangeLog create mode 100644 contrib/perl5/ext/Errno/Errno_pm.PL create mode 100644 contrib/perl5/ext/Errno/Makefile.PL create mode 100644 contrib/perl5/ext/Fcntl/Fcntl.pm create mode 100644 contrib/perl5/ext/Fcntl/Fcntl.xs create mode 100644 contrib/perl5/ext/Fcntl/Makefile.PL create mode 100644 contrib/perl5/ext/GDBM_File/GDBM_File.pm create mode 100644 contrib/perl5/ext/GDBM_File/GDBM_File.xs create mode 100644 contrib/perl5/ext/GDBM_File/Makefile.PL create mode 100644 contrib/perl5/ext/GDBM_File/typemap create mode 100644 contrib/perl5/ext/IO/IO.pm create mode 100644 contrib/perl5/ext/IO/IO.xs create mode 100644 contrib/perl5/ext/IO/Makefile.PL create mode 100644 contrib/perl5/ext/IO/README create mode 100644 contrib/perl5/ext/IO/lib/IO/File.pm create mode 100644 contrib/perl5/ext/IO/lib/IO/Handle.pm create mode 100644 contrib/perl5/ext/IO/lib/IO/Pipe.pm create mode 100644 contrib/perl5/ext/IO/lib/IO/Seekable.pm create mode 100644 contrib/perl5/ext/IO/lib/IO/Select.pm create mode 100644 contrib/perl5/ext/IO/lib/IO/Socket.pm create mode 100644 contrib/perl5/ext/IPC/SysV/ChangeLog create mode 100644 contrib/perl5/ext/IPC/SysV/MANIFEST create mode 100644 contrib/perl5/ext/IPC/SysV/Makefile.PL create mode 100644 contrib/perl5/ext/IPC/SysV/Msg.pm create mode 100644 contrib/perl5/ext/IPC/SysV/README create mode 100644 contrib/perl5/ext/IPC/SysV/Semaphore.pm create mode 100644 contrib/perl5/ext/IPC/SysV/SysV.pm create mode 100644 contrib/perl5/ext/IPC/SysV/SysV.xs create mode 100755 contrib/perl5/ext/IPC/SysV/t/msg.t create mode 100755 contrib/perl5/ext/IPC/SysV/t/sem.t create mode 100644 contrib/perl5/ext/NDBM_File/Makefile.PL create mode 100644 contrib/perl5/ext/NDBM_File/NDBM_File.pm create mode 100644 contrib/perl5/ext/NDBM_File/NDBM_File.xs create mode 100644 contrib/perl5/ext/NDBM_File/hints/dec_osf.pl create mode 100644 contrib/perl5/ext/NDBM_File/hints/dynixptx.pl create mode 100644 contrib/perl5/ext/NDBM_File/hints/solaris.pl create mode 100644 contrib/perl5/ext/NDBM_File/hints/svr4.pl create mode 100644 contrib/perl5/ext/NDBM_File/typemap create mode 100644 contrib/perl5/ext/ODBM_File/Makefile.PL create mode 100644 contrib/perl5/ext/ODBM_File/ODBM_File.pm create mode 100644 contrib/perl5/ext/ODBM_File/ODBM_File.xs create mode 100644 contrib/perl5/ext/ODBM_File/hints/dec_osf.pl create mode 100644 contrib/perl5/ext/ODBM_File/hints/hpux.pl create mode 100644 contrib/perl5/ext/ODBM_File/hints/sco.pl create mode 100644 contrib/perl5/ext/ODBM_File/hints/solaris.pl create mode 100644 contrib/perl5/ext/ODBM_File/hints/svr4.pl create mode 100644 contrib/perl5/ext/ODBM_File/hints/ultrix.pl create mode 100644 contrib/perl5/ext/ODBM_File/typemap create mode 100644 contrib/perl5/ext/Opcode/Makefile.PL create mode 100644 contrib/perl5/ext/Opcode/Opcode.pm create mode 100644 contrib/perl5/ext/Opcode/Opcode.xs create mode 100644 contrib/perl5/ext/Opcode/Safe.pm create mode 100644 contrib/perl5/ext/Opcode/ops.pm create mode 100644 contrib/perl5/ext/POSIX/Makefile.PL create mode 100644 contrib/perl5/ext/POSIX/POSIX.pm create mode 100644 contrib/perl5/ext/POSIX/POSIX.pod create mode 100644 contrib/perl5/ext/POSIX/POSIX.xs create mode 100644 contrib/perl5/ext/POSIX/hints/bsdos.pl create mode 100644 contrib/perl5/ext/POSIX/hints/freebsd.pl create mode 100644 contrib/perl5/ext/POSIX/hints/linux.pl create mode 100644 contrib/perl5/ext/POSIX/hints/netbsd.pl create mode 100644 contrib/perl5/ext/POSIX/hints/next_3.pl create mode 100644 contrib/perl5/ext/POSIX/hints/openbsd.pl create mode 100644 contrib/perl5/ext/POSIX/hints/sunos_4.pl create mode 100644 contrib/perl5/ext/POSIX/typemap create mode 100644 contrib/perl5/ext/SDBM_File/Makefile.PL create mode 100644 contrib/perl5/ext/SDBM_File/SDBM_File.pm create mode 100644 contrib/perl5/ext/SDBM_File/SDBM_File.xs create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/CHANGES create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/COMPARE create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/Makefile.PL create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/README create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/README.too create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/biblio create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/dba.c create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/dbd.c create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/dbe.1 create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/dbe.c create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/dbm.c create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/dbm.h create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/dbu.c create mode 100755 contrib/perl5/ext/SDBM_File/sdbm/grind create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/hash.c create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/linux.patches create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/makefile.sdbm create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/pair.c create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/pair.h create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/readme.ms create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/sdbm.3 create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/sdbm.c create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/sdbm.h create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/tune.h create mode 100644 contrib/perl5/ext/SDBM_File/sdbm/util.c create mode 100644 contrib/perl5/ext/SDBM_File/typemap create mode 100644 contrib/perl5/ext/Socket/Makefile.PL create mode 100644 contrib/perl5/ext/Socket/Socket.pm create mode 100644 contrib/perl5/ext/Socket/Socket.xs create mode 100644 contrib/perl5/ext/Thread/Makefile.PL create mode 100644 contrib/perl5/ext/Thread/Notes create mode 100644 contrib/perl5/ext/Thread/README create mode 100644 contrib/perl5/ext/Thread/Thread.pm create mode 100644 contrib/perl5/ext/Thread/Thread.xs create mode 100644 contrib/perl5/ext/Thread/Thread/Queue.pm create mode 100644 contrib/perl5/ext/Thread/Thread/Semaphore.pm create mode 100644 contrib/perl5/ext/Thread/Thread/Signal.pm create mode 100644 contrib/perl5/ext/Thread/Thread/Specific.pm create mode 100644 contrib/perl5/ext/Thread/create.t create mode 100644 contrib/perl5/ext/Thread/die.t create mode 100644 contrib/perl5/ext/Thread/die2.t create mode 100644 contrib/perl5/ext/Thread/io.t create mode 100644 contrib/perl5/ext/Thread/join.t create mode 100644 contrib/perl5/ext/Thread/join2.t create mode 100644 contrib/perl5/ext/Thread/list.t create mode 100644 contrib/perl5/ext/Thread/lock.t create mode 100644 contrib/perl5/ext/Thread/queue.t create mode 100644 contrib/perl5/ext/Thread/specific.t create mode 100644 contrib/perl5/ext/Thread/sync.t create mode 100644 contrib/perl5/ext/Thread/sync2.t create mode 100644 contrib/perl5/ext/Thread/typemap create mode 100644 contrib/perl5/ext/Thread/unsync.t create mode 100644 contrib/perl5/ext/Thread/unsync2.t create mode 100644 contrib/perl5/ext/Thread/unsync3.t create mode 100644 contrib/perl5/ext/Thread/unsync4.t create mode 100644 contrib/perl5/ext/attrs/Makefile.PL create mode 100644 contrib/perl5/ext/attrs/attrs.pm create mode 100644 contrib/perl5/ext/attrs/attrs.xs create mode 100644 contrib/perl5/ext/re/Makefile.PL create mode 100644 contrib/perl5/ext/re/hints/mpeix.pl create mode 100644 contrib/perl5/ext/re/re.pm create mode 100644 contrib/perl5/ext/re/re.xs create mode 100644 contrib/perl5/ext/util/make_ext create mode 100644 contrib/perl5/ext/util/mkbootstrap (limited to 'contrib/perl5/ext') diff --git a/contrib/perl5/ext/B/B.pm b/contrib/perl5/ext/B/B.pm new file mode 100644 index 0000000..d5137d4 --- /dev/null +++ b/contrib/perl5/ext/B/B.pm @@ -0,0 +1,825 @@ +# B.pm +# +# Copyright (c) 1996, 1997, 1998 Malcolm Beattie +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the README file. +# +package B; +require DynaLoader; +require Exporter; +@ISA = qw(Exporter DynaLoader); +@EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname + class peekop cast_I32 cstring cchar hash threadsv_names + main_root main_start main_cv svref_2object + walkoptree walkoptree_slow walkoptree_exec walksymtable + parents comppadlist sv_undef compile_stats timing_info); + +use strict; +@B::SV::ISA = 'B::OBJECT'; +@B::NULL::ISA = 'B::SV'; +@B::PV::ISA = 'B::SV'; +@B::IV::ISA = 'B::SV'; +@B::NV::ISA = 'B::IV'; +@B::RV::ISA = 'B::SV'; +@B::PVIV::ISA = qw(B::PV B::IV); +@B::PVNV::ISA = qw(B::PV B::NV); +@B::PVMG::ISA = 'B::PVNV'; +@B::PVLV::ISA = 'B::PVMG'; +@B::BM::ISA = 'B::PVMG'; +@B::AV::ISA = 'B::PVMG'; +@B::GV::ISA = 'B::PVMG'; +@B::HV::ISA = 'B::PVMG'; +@B::CV::ISA = 'B::PVMG'; +@B::IO::ISA = 'B::PVMG'; +@B::FM::ISA = 'B::CV'; + +@B::OP::ISA = 'B::OBJECT'; +@B::UNOP::ISA = 'B::OP'; +@B::BINOP::ISA = 'B::UNOP'; +@B::LOGOP::ISA = 'B::UNOP'; +@B::CONDOP::ISA = 'B::UNOP'; +@B::LISTOP::ISA = 'B::BINOP'; +@B::SVOP::ISA = 'B::OP'; +@B::GVOP::ISA = 'B::OP'; +@B::PVOP::ISA = 'B::OP'; +@B::CVOP::ISA = 'B::OP'; +@B::LOOP::ISA = 'B::LISTOP'; +@B::PMOP::ISA = 'B::LISTOP'; +@B::COP::ISA = 'B::OP'; + +@B::SPECIAL::ISA = 'B::OBJECT'; + +{ + # Stop "-w" from complaining about the lack of a real B::OBJECT class + package B::OBJECT; +} + +my $debug; +my $op_count = 0; +my @parents = (); + +sub debug { + my ($class, $value) = @_; + $debug = $value; + walkoptree_debug($value); +} + +# sub OPf_KIDS; +# add to .xs for perl5.002 +sub OPf_KIDS () { 4 } + +sub class { + my $obj = shift; + my $name = ref $obj; + $name =~ s/^.*:://; + return $name; +} + +sub parents { \@parents } + +# For debugging +sub peekop { + my $op = shift; + return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr); +} + +sub walkoptree_slow { + my($op, $method, $level) = @_; + $op_count++; # just for statistics + $level ||= 0; + warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug; + $op->$method($level); + if ($$op && ($op->flags & OPf_KIDS)) { + my $kid; + unshift(@parents, $op); + for ($kid = $op->first; $$kid; $kid = $kid->sibling) { + walkoptree_slow($kid, $method, $level + 1); + } + shift @parents; + } +} + +sub compile_stats { + return "Total number of OPs processed: $op_count\n"; +} + +sub timing_info { + my ($sec, $min, $hr) = localtime; + my ($user, $sys) = times; + sprintf("%02d:%02d:%02d user=$user sys=$sys", + $hr, $min, $sec, $user, $sys); +} + +my %symtable; +sub savesym { + my ($obj, $value) = @_; +# warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug + $symtable{sprintf("sym_%x", $$obj)} = $value; +} + +sub objsym { + my $obj = shift; + return $symtable{sprintf("sym_%x", $$obj)}; +} + +sub walkoptree_exec { + my ($op, $method, $level) = @_; + my ($sym, $ppname); + my $prefix = " " x $level; + for (; $$op; $op = $op->next) { + $sym = objsym($op); + if (defined($sym)) { + print $prefix, "goto $sym\n"; + return; + } + savesym($op, sprintf("%s (0x%lx)", class($op), $$op)); + $op->$method($level); + $ppname = $op->ppaddr; + if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) { + print $prefix, uc($1), " => {\n"; + walkoptree_exec($op->other, $method, $level + 1); + print $prefix, "}\n"; + } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") { + my $pmreplstart = $op->pmreplstart; + if ($$pmreplstart) { + print $prefix, "PMREPLSTART => {\n"; + walkoptree_exec($pmreplstart, $method, $level + 1); + print $prefix, "}\n"; + } + } elsif ($ppname eq "pp_substcont") { + print $prefix, "SUBSTCONT => {\n"; + walkoptree_exec($op->other->pmreplstart, $method, $level + 1); + print $prefix, "}\n"; + $op = $op->other; + } elsif ($ppname eq "pp_cond_expr") { + # pp_cond_expr never returns op_next + print $prefix, "TRUE => {\n"; + walkoptree_exec($op->true, $method, $level + 1); + print $prefix, "}\n"; + $op = $op->false; + redo; + } elsif ($ppname eq "pp_range") { + print $prefix, "TRUE => {\n"; + walkoptree_exec($op->true, $method, $level + 1); + print $prefix, "}\n", $prefix, "FALSE => {\n"; + walkoptree_exec($op->false, $method, $level + 1); + print $prefix, "}\n"; + } elsif ($ppname eq "pp_enterloop") { + print $prefix, "REDO => {\n"; + walkoptree_exec($op->redoop, $method, $level + 1); + print $prefix, "}\n", $prefix, "NEXT => {\n"; + walkoptree_exec($op->nextop, $method, $level + 1); + print $prefix, "}\n", $prefix, "LAST => {\n"; + walkoptree_exec($op->lastop, $method, $level + 1); + print $prefix, "}\n"; + } elsif ($ppname eq "pp_subst") { + my $replstart = $op->pmreplstart; + if ($$replstart) { + print $prefix, "SUBST => {\n"; + walkoptree_exec($replstart, $method, $level + 1); + print $prefix, "}\n"; + } + } + } +} + +sub walksymtable { + my ($symref, $method, $recurse, $prefix) = @_; + my $sym; + no strict 'vars'; + local(*glob); + while (($sym, *glob) = each %$symref) { + if ($sym =~ /::$/) { + $sym = $prefix . $sym; + if ($sym ne "main::" && &$recurse($sym)) { + walksymtable(\%glob, $method, $recurse, $sym); + } + } else { + svref_2object(\*glob)->EGV->$method(); + } + } +} + +{ + package B::Section; + my $output_fh; + my %sections; + + sub new { + my ($class, $section, $symtable, $default) = @_; + $output_fh ||= FileHandle->new_tmpfile; + my $obj = bless [-1, $section, $symtable, $default], $class; + $sections{$section} = $obj; + return $obj; + } + + sub get { + my ($class, $section) = @_; + return $sections{$section}; + } + + sub add { + my $section = shift; + while (defined($_ = shift)) { + print $output_fh "$section->[1]\t$_\n"; + $section->[0]++; + } + } + + sub index { + my $section = shift; + return $section->[0]; + } + + sub name { + my $section = shift; + return $section->[1]; + } + + sub symtable { + my $section = shift; + return $section->[2]; + } + + sub default { + my $section = shift; + return $section->[3]; + } + + sub output { + my ($section, $fh, $format) = @_; + my $name = $section->name; + my $sym = $section->symtable || {}; + my $default = $section->default; + + seek($output_fh, 0, 0); + while (<$output_fh>) { + chomp; + s/^(.*?)\t//; + if ($1 eq $name) { + s{(s\\_[0-9a-f]+)} { + exists($sym->{$1}) ? $sym->{$1} : $default; + }ge; + printf $fh $format, $_; + } + } + } +} + +bootstrap B; + +1; + +__END__ + +=head1 NAME + +B - The Perl Compiler + +=head1 SYNOPSIS + + use B; + +=head1 DESCRIPTION + +The C module supplies classes which allow a Perl program to delve +into its own innards. It is the module used to implement the +"backends" of the Perl compiler. Usage of the compiler does not +require knowledge of this module: see the F module for the +user-visible part. The C module is of use to those who want to +write new compiler backends. This documentation assumes that the +reader knows a fair amount about perl's internals including such +things as SVs, OPs and the internal symbol table and syntax tree +of a program. + +=head1 OVERVIEW OF CLASSES + +The C structures used by Perl's internals to hold SV and OP +information (PVIV, AV, HV, ..., OP, SVOP, UNOP, ...) are modelled on a +class hierarchy and the C module gives access to them via a true +object hierarchy. Structure fields which point to other objects +(whether types of SV or types of OP) are represented by the C +module as Perl objects of the appropriate class. The bulk of the C +module is the methods for accessing fields of these structures. Note +that all access is read-only: you cannot modify the internals by +using this module. + +=head2 SV-RELATED CLASSES + +B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV, +B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in +the obvious way to the underlying C structures of similar names. The +inheritance hierarchy mimics the underlying C "inheritance". Access +methods correspond to the underlying C macros for field access, +usually with the leading "class indication" prefix removed (Sv, Av, +Hv, ...). The leading prefix is only left in cases where its removal +would cause a clash in method name. For example, C stays +as-is since its abbreviation would clash with the "superclass" method +C (corresponding to the C function C). + +=head2 B::SV METHODS + +=over 4 + +=item REFCNT + +=item FLAGS + +=back + +=head2 B::IV METHODS + +=over 4 + +=item IV + +=item IVX + +=item needs64bits + +=item packiv + +=back + +=head2 B::NV METHODS + +=over 4 + +=item NV + +=item NVX + +=back + +=head2 B::RV METHODS + +=over 4 + +=item RV + +=back + +=head2 B::PV METHODS + +=over 4 + +=item PV + +=back + +=head2 B::PVMG METHODS + +=over 4 + +=item MAGIC + +=item SvSTASH + +=back + +=head2 B::MAGIC METHODS + +=over 4 + +=item MOREMAGIC + +=item PRIVATE + +=item TYPE + +=item FLAGS + +=item OBJ + +=item PTR + +=back + +=head2 B::PVLV METHODS + +=over 4 + +=item TARGOFF + +=item TARGLEN + +=item TYPE + +=item TARG + +=back + +=head2 B::BM METHODS + +=over 4 + +=item USEFUL + +=item PREVIOUS + +=item RARE + +=item TABLE + +=back + +=head2 B::GV METHODS + +=over 4 + +=item NAME + +=item STASH + +=item SV + +=item IO + +=item FORM + +=item AV + +=item HV + +=item EGV + +=item CV + +=item CVGEN + +=item LINE + +=item FILEGV + +=item GvREFCNT + +=item FLAGS + +=back + +=head2 B::IO METHODS + +=over 4 + +=item LINES + +=item PAGE + +=item PAGE_LEN + +=item LINES_LEFT + +=item TOP_NAME + +=item TOP_GV + +=item FMT_NAME + +=item FMT_GV + +=item BOTTOM_NAME + +=item BOTTOM_GV + +=item SUBPROCESS + +=item IoTYPE + +=item IoFLAGS + +=back + +=head2 B::AV METHODS + +=over 4 + +=item FILL + +=item MAX + +=item OFF + +=item ARRAY + +=item AvFLAGS + +=back + +=head2 B::CV METHODS + +=over 4 + +=item STASH + +=item START + +=item ROOT + +=item GV + +=item FILEGV + +=item DEPTH + +=item PADLIST + +=item OUTSIDE + +=item XSUB + +=item XSUBANY + +=back + +=head2 B::HV METHODS + +=over 4 + +=item FILL + +=item MAX + +=item KEYS + +=item RITER + +=item NAME + +=item PMROOT + +=item ARRAY + +=back + +=head2 OP-RELATED CLASSES + +B::OP, B::UNOP, B::BINOP, B::LOGOP, B::CONDOP, B::LISTOP, B::PMOP, +B::SVOP, B::GVOP, B::PVOP, B::CVOP, B::LOOP, B::COP. +These classes correspond in +the obvious way to the underlying C structures of similar names. The +inheritance hierarchy mimics the underlying C "inheritance". Access +methods correspond to the underlying C structre field names, with the +leading "class indication" prefix removed (op_). + +=head2 B::OP METHODS + +=over 4 + +=item next + +=item sibling + +=item ppaddr + +This returns the function name as a string (e.g. pp_add, pp_rv2av). + +=item desc + +This returns the op description from the global C op_desc array +(e.g. "addition" "array deref"). + +=item targ + +=item type + +=item seq + +=item flags + +=item private + +=back + +=head2 B::UNOP METHOD + +=over 4 + +=item first + +=back + +=head2 B::BINOP METHOD + +=over 4 + +=item last + +=back + +=head2 B::LOGOP METHOD + +=over 4 + +=item other + +=back + +=head2 B::CONDOP METHODS + +=over 4 + +=item true + +=item false + +=back + +=head2 B::LISTOP METHOD + +=over 4 + +=item children + +=back + +=head2 B::PMOP METHODS + +=over 4 + +=item pmreplroot + +=item pmreplstart + +=item pmnext + +=item pmregexp + +=item pmflags + +=item pmpermflags + +=item precomp + +=back + +=head2 B::SVOP METHOD + +=over 4 + +=item sv + +=back + +=head2 B::GVOP METHOD + +=over 4 + +=item gv + +=back + +=head2 B::PVOP METHOD + +=over 4 + +=item pv + +=back + +=head2 B::LOOP METHODS + +=over 4 + +=item redoop + +=item nextop + +=item lastop + +=back + +=head2 B::COP METHODS + +=over 4 + +=item label + +=item stash + +=item filegv + +=item cop_seq + +=item arybase + +=item line + +=back + +=head1 FUNCTIONS EXPORTED BY C + +The C module exports a variety of functions: some are simple +utility functions, others provide a Perl program with a way to +get an initial "handle" on an internal object. + +=over 4 + +=item main_cv + +Return the (faked) CV corresponding to the main part of the Perl +program. + +=item main_root + +Returns the root op (i.e. an object in the appropriate B::OP-derived +class) of the main part of the Perl program. + +=item main_start + +Returns the starting op of the main part of the Perl program. + +=item comppadlist + +Returns the AV object (i.e. in class B::AV) of the global comppadlist. + +=item sv_undef + +Returns the SV object corresponding to the C variable C. + +=item sv_yes + +Returns the SV object corresponding to the C variable C. + +=item sv_no + +Returns the SV object corresponding to the C variable C. + +=item walkoptree(OP, METHOD) + +Does a tree-walk of the syntax tree based at OP and calls METHOD on +each op it visits. Each node is visited before its children. If +C (q.v.) has been called to turn debugging on then +the method C is called on each op before METHOD is +called. + +=item walkoptree_debug(DEBUG) + +Returns the current debugging flag for C. If the optional +DEBUG argument is non-zero, it sets the debugging flag to that. See +the description of C above for what the debugging flag +does. + +=item walksymtable(SYMREF, METHOD, RECURSE) + +Walk the symbol table starting at SYMREF and call METHOD on each +symbol visited. When the walk reached package symbols "Foo::" it +invokes RECURSE and only recurses into the package if that sub +returns true. + +=item svref_2object(SV) + +Takes any Perl variable and turns it into an object in the +appropriate B::OP-derived or B::SV-derived class. Apart from functions +such as C, this is the primary way to get an initial +"handle" on a internal perl data structure which can then be followed +with the other access methods. + +=item ppname(OPNUM) + +Return the PP function name (e.g. "pp_add") of op number OPNUM. + +=item hash(STR) + +Returns a string in the form "0x..." representing the value of the +internal hash function used by perl on string STR. + +=item cast_I32(I) + +Casts I to the internal I32 type used by that perl. + + +=item minus_c + +Does the equivalent of the C<-c> command-line option. Obviously, this +is only useful in a BEGIN block or else the flag is set too late. + + +=item cstring(STR) + +Returns a double-quote-surrounded escaped version of STR which can +be used as a string in C source code. + +=item class(OBJ) + +Returns the class of an object without the part of the classname +preceding the first "::". This is used to turn "B::UNOP" into +"UNOP" for example. + +=item threadsv_names + +In a perl compiled for threads, this returns a list of the special +per-thread threadsv variables. + +=item byteload_fh(FILEHANDLE) + +Load the contents of FILEHANDLE as bytecode. See documentation for +the B module in F for how to generate bytecode. + +=back + +=head1 AUTHOR + +Malcolm Beattie, C + +=cut diff --git a/contrib/perl5/ext/B/B.xs b/contrib/perl5/ext/B/B.xs new file mode 100644 index 0000000..8dbc915 --- /dev/null +++ b/contrib/perl5/ext/B/B.xs @@ -0,0 +1,1207 @@ +/* B.xs + * + * Copyright (c) 1996 Malcolm Beattie + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "INTERN.h" + +#ifdef PERL_OBJECT +#undef op_name +#undef opargs +#undef op_desc +#define op_name (pPerl->Perl_get_op_names()) +#define opargs (pPerl->Perl_get_opargs()) +#define op_desc (pPerl->Perl_get_op_descs()) +#endif + +#ifdef PerlIO +typedef PerlIO * InputStream; +#else +typedef FILE * InputStream; +#endif + + +static char *svclassnames[] = { + "B::NULL", + "B::IV", + "B::NV", + "B::RV", + "B::PV", + "B::PVIV", + "B::PVNV", + "B::PVMG", + "B::BM", + "B::PVLV", + "B::AV", + "B::HV", + "B::CV", + "B::GV", + "B::FM", + "B::IO", +}; + +typedef enum { + OPc_NULL, /* 0 */ + OPc_BASEOP, /* 1 */ + OPc_UNOP, /* 2 */ + OPc_BINOP, /* 3 */ + OPc_LOGOP, /* 4 */ + OPc_CONDOP, /* 5 */ + OPc_LISTOP, /* 6 */ + OPc_PMOP, /* 7 */ + OPc_SVOP, /* 8 */ + OPc_GVOP, /* 9 */ + OPc_PVOP, /* 10 */ + OPc_CVOP, /* 11 */ + OPc_LOOP, /* 12 */ + OPc_COP /* 13 */ +} opclass; + +static char *opclassnames[] = { + "B::NULL", + "B::OP", + "B::UNOP", + "B::BINOP", + "B::LOGOP", + "B::CONDOP", + "B::LISTOP", + "B::PMOP", + "B::SVOP", + "B::GVOP", + "B::PVOP", + "B::CVOP", + "B::LOOP", + "B::COP" +}; + +static int walkoptree_debug = 0; /* Flag for walkoptree debug hook */ + +static opclass +cc_opclass(OP *o) +{ + if (!o) + return OPc_NULL; + + if (o->op_type == 0) + return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP; + + if (o->op_type == OP_SASSIGN) + return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP); + + switch (opargs[o->op_type] & OA_CLASS_MASK) { + case OA_BASEOP: + return OPc_BASEOP; + + case OA_UNOP: + return OPc_UNOP; + + case OA_BINOP: + return OPc_BINOP; + + case OA_LOGOP: + return OPc_LOGOP; + + case OA_CONDOP: + return OPc_CONDOP; + + case OA_LISTOP: + return OPc_LISTOP; + + case OA_PMOP: + return OPc_PMOP; + + case OA_SVOP: + return OPc_SVOP; + + case OA_GVOP: + return OPc_GVOP; + + case OA_PVOP: + return OPc_PVOP; + + case OA_LOOP: + return OPc_LOOP; + + case OA_COP: + return OPc_COP; + + case OA_BASEOP_OR_UNOP: + /* + * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on + * whether parens were seen. perly.y uses OPf_SPECIAL to + * signal whether a BASEOP had empty parens or none. + * Some other UNOPs are created later, though, so the best + * test is OPf_KIDS, which is set in newUNOP. + */ + return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP; + + case OA_FILESTATOP: + /* + * The file stat OPs are created via UNI(OP_foo) in toke.c but use + * the OPf_REF flag to distinguish between OP types instead of the + * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we + * return OPc_UNOP so that walkoptree can find our children. If + * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set + * (no argument to the operator) it's an OP; with OPf_REF set it's + * a GVOP (and op_gv is the GV for the filehandle argument). + */ + return ((o->op_flags & OPf_KIDS) ? OPc_UNOP : + (o->op_flags & OPf_REF) ? OPc_GVOP : OPc_BASEOP); + + case OA_LOOPEXOP: + /* + * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a + * label was omitted (in which case it's a BASEOP) or else a term was + * seen. In this last case, all except goto are definitely PVOP but + * goto is either a PVOP (with an ordinary constant label), an UNOP + * with OPf_STACKED (with a non-constant non-sub) or an UNOP for + * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to + * get set. + */ + if (o->op_flags & OPf_STACKED) + return OPc_UNOP; + else if (o->op_flags & OPf_SPECIAL) + return OPc_BASEOP; + else + return OPc_PVOP; + } + warn("can't determine class of operator %s, assuming BASEOP\n", + op_name[o->op_type]); + return OPc_BASEOP; +} + +static char * +cc_opclassname(OP *o) +{ + return opclassnames[cc_opclass(o)]; +} + +static SV * +make_sv_object(SV *arg, SV *sv) +{ + char *type = 0; + IV iv; + + for (iv = 0; iv < sizeof(PL_specialsv_list)/sizeof(SV*); iv++) { + if (sv == PL_specialsv_list[iv]) { + type = "B::SPECIAL"; + break; + } + } + if (!type) { + type = svclassnames[SvTYPE(sv)]; + iv = (IV)sv; + } + sv_setiv(newSVrv(arg, type), iv); + return arg; +} + +static SV * +make_mg_object(SV *arg, MAGIC *mg) +{ + sv_setiv(newSVrv(arg, "B::MAGIC"), (IV)mg); + return arg; +} + +static SV * +cstring(SV *sv) +{ + SV *sstr = newSVpv("", 0); + STRLEN len; + char *s; + + if (!SvOK(sv)) + sv_setpvn(sstr, "0", 1); + else + { + /* XXX Optimise? */ + s = SvPV(sv, len); + sv_catpv(sstr, "\""); + for (; len; len--, s++) + { + /* At least try a little for readability */ + if (*s == '"') + sv_catpv(sstr, "\\\""); + else if (*s == '\\') + sv_catpv(sstr, "\\\\"); + else if (*s >= ' ' && *s < 127) /* XXX not portable */ + sv_catpvn(sstr, s, 1); + else if (*s == '\n') + sv_catpv(sstr, "\\n"); + else if (*s == '\r') + sv_catpv(sstr, "\\r"); + else if (*s == '\t') + sv_catpv(sstr, "\\t"); + else if (*s == '\a') + sv_catpv(sstr, "\\a"); + else if (*s == '\b') + sv_catpv(sstr, "\\b"); + else if (*s == '\f') + sv_catpv(sstr, "\\f"); + else if (*s == '\v') + sv_catpv(sstr, "\\v"); + else + { + /* no trigraph support */ + char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */ + /* Don't want promotion of a signed -1 char in sprintf args */ + unsigned char c = (unsigned char) *s; + sprintf(escbuff, "\\%03o", c); + sv_catpv(sstr, escbuff); + } + /* XXX Add line breaks if string is long */ + } + sv_catpv(sstr, "\""); + } + return sstr; +} + +static SV * +cchar(SV *sv) +{ + SV *sstr = newSVpv("'", 0); + char *s = SvPV(sv, PL_na); + + if (*s == '\'') + sv_catpv(sstr, "\\'"); + else if (*s == '\\') + sv_catpv(sstr, "\\\\"); + else if (*s >= ' ' && *s < 127) /* XXX not portable */ + sv_catpvn(sstr, s, 1); + else if (*s == '\n') + sv_catpv(sstr, "\\n"); + else if (*s == '\r') + sv_catpv(sstr, "\\r"); + else if (*s == '\t') + sv_catpv(sstr, "\\t"); + else if (*s == '\a') + sv_catpv(sstr, "\\a"); + else if (*s == '\b') + sv_catpv(sstr, "\\b"); + else if (*s == '\f') + sv_catpv(sstr, "\\f"); + else if (*s == '\v') + sv_catpv(sstr, "\\v"); + else + { + /* no trigraph support */ + char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */ + /* Don't want promotion of a signed -1 char in sprintf args */ + unsigned char c = (unsigned char) *s; + sprintf(escbuff, "\\%03o", c); + sv_catpv(sstr, escbuff); + } + sv_catpv(sstr, "'"); + return sstr; +} + +#ifdef INDIRECT_BGET_MACROS +void freadpv(U32 len, void *data) +{ + New(666, pv.xpv_pv, len, char); + fread(pv.xpv_pv, 1, len, (FILE*)data); + pv.xpv_len = len; + pv.xpv_cur = len - 1; +} + +void byteload_fh(InputStream fp) +{ + struct bytestream bs; + bs.data = fp; + bs.fgetc = (int(*) _((void*)))fgetc; + bs.fread = (int(*) _((char*,size_t,size_t,void*)))fread; + bs.freadpv = freadpv; + byterun(bs); +} + +static int fgetc_fromstring(void *data) +{ + char **strp = (char **)data; + return *(*strp)++; +} + +static int fread_fromstring(char *argp, size_t elemsize, size_t nelem, + void *data) +{ + char **strp = (char **)data; + size_t len = elemsize * nelem; + + memcpy(argp, *strp, len); + *strp += len; + return (int)len; +} + +static void freadpv_fromstring(U32 len, void *data) +{ + char **strp = (char **)data; + + New(666, pv.xpv_pv, len, char); + memcpy(pv.xpv_pv, *strp, len); + pv.xpv_len = len; + pv.xpv_cur = len - 1; + *strp += len; +} + +void byteload_string(char *str) +{ + struct bytestream bs; + bs.data = &str; + bs.fgetc = fgetc_fromstring; + bs.fread = fread_fromstring; + bs.freadpv = freadpv_fromstring; + byterun(bs); +} +#else +void byteload_fh(InputStream fp) +{ + byterun(fp); +} + +void byteload_string(char *str) +{ + croak("Must compile with -DINDIRECT_BGET_MACROS for byteload_string"); +} +#endif /* INDIRECT_BGET_MACROS */ + +void +walkoptree(SV *opsv, char *method) +{ + dSP; + OP *o; + + if (!SvROK(opsv)) + croak("opsv is not a reference"); + opsv = sv_mortalcopy(opsv); + o = (OP*)SvIV((SV*)SvRV(opsv)); + if (walkoptree_debug) { + PUSHMARK(sp); + XPUSHs(opsv); + PUTBACK; + perl_call_method("walkoptree_debug", G_DISCARD); + } + PUSHMARK(sp); + XPUSHs(opsv); + PUTBACK; + perl_call_method(method, G_DISCARD); + if (o && (o->op_flags & OPf_KIDS)) { + OP *kid; + for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) { + /* Use the same opsv. Rely on methods not to mess it up. */ + sv_setiv(newSVrv(opsv, cc_opclassname(kid)), (IV)kid); + walkoptree(opsv, method); + } + } +} + +typedef OP *B__OP; +typedef UNOP *B__UNOP; +typedef BINOP *B__BINOP; +typedef LOGOP *B__LOGOP; +typedef CONDOP *B__CONDOP; +typedef LISTOP *B__LISTOP; +typedef PMOP *B__PMOP; +typedef SVOP *B__SVOP; +typedef GVOP *B__GVOP; +typedef PVOP *B__PVOP; +typedef LOOP *B__LOOP; +typedef COP *B__COP; + +typedef SV *B__SV; +typedef SV *B__IV; +typedef SV *B__PV; +typedef SV *B__NV; +typedef SV *B__PVMG; +typedef SV *B__PVLV; +typedef SV *B__BM; +typedef SV *B__RV; +typedef AV *B__AV; +typedef HV *B__HV; +typedef CV *B__CV; +typedef GV *B__GV; +typedef IO *B__IO; + +typedef MAGIC *B__MAGIC; + +MODULE = B PACKAGE = B PREFIX = B_ + +PROTOTYPES: DISABLE + +BOOT: + INIT_SPECIALSV_LIST; + +#define B_main_cv() PL_main_cv +#define B_main_root() PL_main_root +#define B_main_start() PL_main_start +#define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv)) +#define B_sv_undef() &PL_sv_undef +#define B_sv_yes() &PL_sv_yes +#define B_sv_no() &PL_sv_no + +B::CV +B_main_cv() + +B::OP +B_main_root() + +B::OP +B_main_start() + +B::AV +B_comppadlist() + +B::SV +B_sv_undef() + +B::SV +B_sv_yes() + +B::SV +B_sv_no() + +MODULE = B PACKAGE = B + + +void +walkoptree(opsv, method) + SV * opsv + char * method + +int +walkoptree_debug(...) + CODE: + RETVAL = walkoptree_debug; + if (items > 0 && SvTRUE(ST(1))) + walkoptree_debug = 1; + OUTPUT: + RETVAL + +int +byteload_fh(fp) + InputStream fp + CODE: + byteload_fh(fp); + RETVAL = 1; + OUTPUT: + RETVAL + +void +byteload_string(str) + char * str + +#define address(sv) (IV)sv + +IV +address(sv) + SV * sv + +B::SV +svref_2object(sv) + SV * sv + CODE: + if (!SvROK(sv)) + croak("argument is not a reference"); + RETVAL = (SV*)SvRV(sv); + OUTPUT: + RETVAL + +void +ppname(opnum) + int opnum + CODE: + ST(0) = sv_newmortal(); + if (opnum >= 0 && opnum < PL_maxo) { + sv_setpvn(ST(0), "pp_", 3); + sv_catpv(ST(0), op_name[opnum]); + } + +void +hash(sv) + SV * sv + CODE: + char *s; + STRLEN len; + U32 hash = 0; + char hexhash[11]; /* must fit "0xffffffff" plus trailing \0 */ + s = SvPV(sv, len); + while (len--) + hash = hash * 33 + *s++; + sprintf(hexhash, "0x%x", hash); + ST(0) = sv_2mortal(newSVpv(hexhash, 0)); + +#define cast_I32(foo) (I32)foo +IV +cast_I32(i) + IV i + +void +minus_c() + CODE: + PL_minus_c = TRUE; + +SV * +cstring(sv) + SV * sv + +SV * +cchar(sv) + SV * sv + +void +threadsv_names() + PPCODE: +#ifdef USE_THREADS + int i; + STRLEN len = strlen(PL_threadsv_names); + + EXTEND(sp, len); + for (i = 0; i < len; i++) + PUSHs(sv_2mortal(newSVpv(&PL_threadsv_names[i], 1))); +#endif + + +#define OP_next(o) o->op_next +#define OP_sibling(o) o->op_sibling +#define OP_desc(o) op_desc[o->op_type] +#define OP_targ(o) o->op_targ +#define OP_type(o) o->op_type +#define OP_seq(o) o->op_seq +#define OP_flags(o) o->op_flags +#define OP_private(o) o->op_private + +MODULE = B PACKAGE = B::OP PREFIX = OP_ + +B::OP +OP_next(o) + B::OP o + +B::OP +OP_sibling(o) + B::OP o + +char * +OP_ppaddr(o) + B::OP o + CODE: + ST(0) = sv_newmortal(); + sv_setpvn(ST(0), "pp_", 3); + sv_catpv(ST(0), op_name[o->op_type]); + +char * +OP_desc(o) + B::OP o + +U16 +OP_targ(o) + B::OP o + +U16 +OP_type(o) + B::OP o + +U16 +OP_seq(o) + B::OP o + +U8 +OP_flags(o) + B::OP o + +U8 +OP_private(o) + B::OP o + +#define UNOP_first(o) o->op_first + +MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_ + +B::OP +UNOP_first(o) + B::UNOP o + +#define BINOP_last(o) o->op_last + +MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_ + +B::OP +BINOP_last(o) + B::BINOP o + +#define LOGOP_other(o) o->op_other + +MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_ + +B::OP +LOGOP_other(o) + B::LOGOP o + +#define CONDOP_true(o) o->op_true +#define CONDOP_false(o) o->op_false + +MODULE = B PACKAGE = B::CONDOP PREFIX = CONDOP_ + +B::OP +CONDOP_true(o) + B::CONDOP o + +B::OP +CONDOP_false(o) + B::CONDOP o + +#define LISTOP_children(o) o->op_children + +MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_ + +U32 +LISTOP_children(o) + B::LISTOP o + +#define PMOP_pmreplroot(o) o->op_pmreplroot +#define PMOP_pmreplstart(o) o->op_pmreplstart +#define PMOP_pmnext(o) o->op_pmnext +#define PMOP_pmregexp(o) o->op_pmregexp +#define PMOP_pmflags(o) o->op_pmflags +#define PMOP_pmpermflags(o) o->op_pmpermflags + +MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_ + +void +PMOP_pmreplroot(o) + B::PMOP o + OP * root = NO_INIT + CODE: + ST(0) = sv_newmortal(); + root = o->op_pmreplroot; + /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */ + if (o->op_type == OP_PUSHRE) { + sv_setiv(newSVrv(ST(0), root ? + svclassnames[SvTYPE((SV*)root)] : "B::SV"), + (IV)root); + } + else { + sv_setiv(newSVrv(ST(0), cc_opclassname(root)), (IV)root); + } + +B::OP +PMOP_pmreplstart(o) + B::PMOP o + +B::PMOP +PMOP_pmnext(o) + B::PMOP o + +U16 +PMOP_pmflags(o) + B::PMOP o + +U16 +PMOP_pmpermflags(o) + B::PMOP o + +void +PMOP_precomp(o) + B::PMOP o + REGEXP * rx = NO_INIT + CODE: + ST(0) = sv_newmortal(); + rx = o->op_pmregexp; + if (rx) + sv_setpvn(ST(0), rx->precomp, rx->prelen); + +#define SVOP_sv(o) o->op_sv + +MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_ + + +B::SV +SVOP_sv(o) + B::SVOP o + +#define GVOP_gv(o) o->op_gv + +MODULE = B PACKAGE = B::GVOP PREFIX = GVOP_ + + +B::GV +GVOP_gv(o) + B::GVOP o + +MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_ + +void +PVOP_pv(o) + B::PVOP o + CODE: + /* + * OP_TRANS uses op_pv to point to a table of 256 shorts + * whereas other PVOPs point to a null terminated string. + */ + ST(0) = sv_2mortal(newSVpv(o->op_pv, (o->op_type == OP_TRANS) ? + 256 * sizeof(short) : 0)); + +#define LOOP_redoop(o) o->op_redoop +#define LOOP_nextop(o) o->op_nextop +#define LOOP_lastop(o) o->op_lastop + +MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_ + + +B::OP +LOOP_redoop(o) + B::LOOP o + +B::OP +LOOP_nextop(o) + B::LOOP o + +B::OP +LOOP_lastop(o) + B::LOOP o + +#define COP_label(o) o->cop_label +#define COP_stash(o) o->cop_stash +#define COP_filegv(o) o->cop_filegv +#define COP_cop_seq(o) o->cop_seq +#define COP_arybase(o) o->cop_arybase +#define COP_line(o) o->cop_line + +MODULE = B PACKAGE = B::COP PREFIX = COP_ + +char * +COP_label(o) + B::COP o + +B::HV +COP_stash(o) + B::COP o + +B::GV +COP_filegv(o) + B::COP o + +U32 +COP_cop_seq(o) + B::COP o + +I32 +COP_arybase(o) + B::COP o + +U16 +COP_line(o) + B::COP o + +MODULE = B PACKAGE = B::SV PREFIX = Sv + +U32 +SvREFCNT(sv) + B::SV sv + +U32 +SvFLAGS(sv) + B::SV sv + +MODULE = B PACKAGE = B::IV PREFIX = Sv + +IV +SvIV(sv) + B::IV sv + +IV +SvIVX(sv) + B::IV sv + +MODULE = B PACKAGE = B::IV + +#define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv)) + +int +needs64bits(sv) + B::IV sv + +void +packiv(sv) + B::IV sv + CODE: + if (sizeof(IV) == 8) { + U32 wp[2]; + IV iv = SvIVX(sv); + /* + * The following way of spelling 32 is to stop compilers on + * 32-bit architectures from moaning about the shift count + * being >= the width of the type. Such architectures don't + * reach this code anyway (unless sizeof(IV) > 8 but then + * everything else breaks too so I'm not fussed at the moment). + */ + wp[0] = htonl(((U32)iv) >> (sizeof(IV)*4)); + wp[1] = htonl(iv & 0xffffffff); + ST(0) = sv_2mortal(newSVpv((char *)wp, 8)); + } else { + U32 w = htonl((U32)SvIVX(sv)); + ST(0) = sv_2mortal(newSVpv((char *)&w, 4)); + } + +MODULE = B PACKAGE = B::NV PREFIX = Sv + +double +SvNV(sv) + B::NV sv + +double +SvNVX(sv) + B::NV sv + +MODULE = B PACKAGE = B::RV PREFIX = Sv + +B::SV +SvRV(sv) + B::RV sv + +MODULE = B PACKAGE = B::PV PREFIX = Sv + +void +SvPV(sv) + B::PV sv + CODE: + ST(0) = sv_newmortal(); + sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv)); + +MODULE = B PACKAGE = B::PVMG PREFIX = Sv + +void +SvMAGIC(sv) + B::PVMG sv + MAGIC * mg = NO_INIT + PPCODE: + for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) + XPUSHs(make_mg_object(sv_newmortal(), mg)); + +MODULE = B PACKAGE = B::PVMG + +B::HV +SvSTASH(sv) + B::PVMG sv + +#define MgMOREMAGIC(mg) mg->mg_moremagic +#define MgPRIVATE(mg) mg->mg_private +#define MgTYPE(mg) mg->mg_type +#define MgFLAGS(mg) mg->mg_flags +#define MgOBJ(mg) mg->mg_obj + +MODULE = B PACKAGE = B::MAGIC PREFIX = Mg + +B::MAGIC +MgMOREMAGIC(mg) + B::MAGIC mg + +U16 +MgPRIVATE(mg) + B::MAGIC mg + +char +MgTYPE(mg) + B::MAGIC mg + +U8 +MgFLAGS(mg) + B::MAGIC mg + +B::SV +MgOBJ(mg) + B::MAGIC mg + +void +MgPTR(mg) + B::MAGIC mg + CODE: + ST(0) = sv_newmortal(); + if (mg->mg_ptr) + sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len); + +MODULE = B PACKAGE = B::PVLV PREFIX = Lv + +U32 +LvTARGOFF(sv) + B::PVLV sv + +U32 +LvTARGLEN(sv) + B::PVLV sv + +char +LvTYPE(sv) + B::PVLV sv + +B::SV +LvTARG(sv) + B::PVLV sv + +MODULE = B PACKAGE = B::BM PREFIX = Bm + +I32 +BmUSEFUL(sv) + B::BM sv + +U16 +BmPREVIOUS(sv) + B::BM sv + +U8 +BmRARE(sv) + B::BM sv + +void +BmTABLE(sv) + B::BM sv + STRLEN len = NO_INIT + char * str = NO_INIT + CODE: + str = SvPV(sv, len); + /* Boyer-Moore table is just after string and its safety-margin \0 */ + ST(0) = sv_2mortal(newSVpv(str + len + 1, 256)); + +MODULE = B PACKAGE = B::GV PREFIX = Gv + +void +GvNAME(gv) + B::GV gv + CODE: + ST(0) = sv_2mortal(newSVpv(GvNAME(gv), GvNAMELEN(gv))); + +B::HV +GvSTASH(gv) + B::GV gv + +B::SV +GvSV(gv) + B::GV gv + +B::IO +GvIO(gv) + B::GV gv + +B::CV +GvFORM(gv) + B::GV gv + +B::AV +GvAV(gv) + B::GV gv + +B::HV +GvHV(gv) + B::GV gv + +B::GV +GvEGV(gv) + B::GV gv + +B::CV +GvCV(gv) + B::GV gv + +U32 +GvCVGEN(gv) + B::GV gv + +U16 +GvLINE(gv) + B::GV gv + +B::GV +GvFILEGV(gv) + B::GV gv + +MODULE = B PACKAGE = B::GV + +U32 +GvREFCNT(gv) + B::GV gv + +U8 +GvFLAGS(gv) + B::GV gv + +MODULE = B PACKAGE = B::IO PREFIX = Io + +long +IoLINES(io) + B::IO io + +long +IoPAGE(io) + B::IO io + +long +IoPAGE_LEN(io) + B::IO io + +long +IoLINES_LEFT(io) + B::IO io + +char * +IoTOP_NAME(io) + B::IO io + +B::GV +IoTOP_GV(io) + B::IO io + +char * +IoFMT_NAME(io) + B::IO io + +B::GV +IoFMT_GV(io) + B::IO io + +char * +IoBOTTOM_NAME(io) + B::IO io + +B::GV +IoBOTTOM_GV(io) + B::IO io + +short +IoSUBPROCESS(io) + B::IO io + +MODULE = B PACKAGE = B::IO + +char +IoTYPE(io) + B::IO io + +U8 +IoFLAGS(io) + B::IO io + +MODULE = B PACKAGE = B::AV PREFIX = Av + +SSize_t +AvFILL(av) + B::AV av + +SSize_t +AvMAX(av) + B::AV av + +#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off + +IV +AvOFF(av) + B::AV av + +void +AvARRAY(av) + B::AV av + PPCODE: + if (AvFILL(av) >= 0) { + SV **svp = AvARRAY(av); + I32 i; + for (i = 0; i <= AvFILL(av); i++) + XPUSHs(make_sv_object(sv_newmortal(), svp[i])); + } + +MODULE = B PACKAGE = B::AV + +U8 +AvFLAGS(av) + B::AV av + +MODULE = B PACKAGE = B::CV PREFIX = Cv + +B::HV +CvSTASH(cv) + B::CV cv + +B::OP +CvSTART(cv) + B::CV cv + +B::OP +CvROOT(cv) + B::CV cv + +B::GV +CvGV(cv) + B::CV cv + +B::GV +CvFILEGV(cv) + B::CV cv + +long +CvDEPTH(cv) + B::CV cv + +B::AV +CvPADLIST(cv) + B::CV cv + +B::CV +CvOUTSIDE(cv) + B::CV cv + +void +CvXSUB(cv) + B::CV cv + CODE: + ST(0) = sv_2mortal(newSViv((IV)CvXSUB(cv))); + + +void +CvXSUBANY(cv) + B::CV cv + CODE: + ST(0) = sv_2mortal(newSViv(CvXSUBANY(cv).any_iv)); + +MODULE = B PACKAGE = B::HV PREFIX = Hv + +STRLEN +HvFILL(hv) + B::HV hv + +STRLEN +HvMAX(hv) + B::HV hv + +I32 +HvKEYS(hv) + B::HV hv + +I32 +HvRITER(hv) + B::HV hv + +char * +HvNAME(hv) + B::HV hv + +B::PMOP +HvPMROOT(hv) + B::HV hv + +void +HvARRAY(hv) + B::HV hv + PPCODE: + if (HvKEYS(hv) > 0) { + SV *sv; + char *key; + I32 len; + (void)hv_iterinit(hv); + EXTEND(sp, HvKEYS(hv) * 2); + while (sv = hv_iternextsv(hv, &key, &len)) { + PUSHs(newSVpv(key, len)); + PUSHs(make_sv_object(sv_newmortal(), sv)); + } + } diff --git a/contrib/perl5/ext/B/B/Asmdata.pm b/contrib/perl5/ext/B/B/Asmdata.pm new file mode 100644 index 0000000..f3e57a1 --- /dev/null +++ b/contrib/perl5/ext/B/B/Asmdata.pm @@ -0,0 +1,170 @@ +# +# Copyright (c) 1996-1998 Malcolm Beattie +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the README file. +# +# +# +# This file is autogenerated from bytecode.pl. Changes made here will be lost. +# +package B::Asmdata; +use Exporter; +@ISA = qw(Exporter); +@EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name); +use vars qw(%insn_data @insn_name @optype @specialsv_name); + +@optype = qw(OP UNOP BINOP LOGOP CONDOP LISTOP PMOP SVOP GVOP PVOP LOOP COP); +@specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no); + +# XXX insn_data is initialised this way because with a large +# %insn_data = (foo => [...], bar => [...], ...) initialiser +# I get a hard-to-track-down stack underflow and segfault. +$insn_data{comment} = [35, \&PUT_comment_t, "GET_comment_t"]; +$insn_data{nop} = [10, \&PUT_none, "GET_none"]; +$insn_data{ret} = [0, \&PUT_none, "GET_none"]; +$insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"]; +$insn_data{ldop} = [2, \&PUT_opindex, "GET_opindex"]; +$insn_data{stsv} = [3, \&PUT_U32, "GET_U32"]; +$insn_data{stop} = [4, \&PUT_U32, "GET_U32"]; +$insn_data{ldspecsv} = [5, \&PUT_U8, "GET_U8"]; +$insn_data{newsv} = [6, \&PUT_U8, "GET_U8"]; +$insn_data{newop} = [7, \&PUT_U8, "GET_U8"]; +$insn_data{newopn} = [8, \&PUT_U8, "GET_U8"]; +$insn_data{newpv} = [9, \&PUT_PV, "GET_PV"]; +$insn_data{pv_cur} = [11, \&PUT_U32, "GET_U32"]; +$insn_data{pv_free} = [12, \&PUT_none, "GET_none"]; +$insn_data{sv_upgrade} = [13, \&PUT_U8, "GET_U8"]; +$insn_data{sv_refcnt} = [14, \&PUT_U32, "GET_U32"]; +$insn_data{sv_refcnt_add} = [15, \&PUT_I32, "GET_I32"]; +$insn_data{sv_flags} = [16, \&PUT_U32, "GET_U32"]; +$insn_data{xrv} = [17, \&PUT_svindex, "GET_svindex"]; +$insn_data{xpv} = [18, \&PUT_none, "GET_none"]; +$insn_data{xiv32} = [19, \&PUT_I32, "GET_I32"]; +$insn_data{xiv64} = [20, \&PUT_IV64, "GET_IV64"]; +$insn_data{xnv} = [21, \&PUT_double, "GET_double"]; +$insn_data{xlv_targoff} = [22, \&PUT_U32, "GET_U32"]; +$insn_data{xlv_targlen} = [23, \&PUT_U32, "GET_U32"]; +$insn_data{xlv_targ} = [24, \&PUT_svindex, "GET_svindex"]; +$insn_data{xlv_type} = [25, \&PUT_U8, "GET_U8"]; +$insn_data{xbm_useful} = [26, \&PUT_I32, "GET_I32"]; +$insn_data{xbm_previous} = [27, \&PUT_U16, "GET_U16"]; +$insn_data{xbm_rare} = [28, \&PUT_U8, "GET_U8"]; +$insn_data{xfm_lines} = [29, \&PUT_I32, "GET_I32"]; +$insn_data{xio_lines} = [30, \&PUT_I32, "GET_I32"]; +$insn_data{xio_page} = [31, \&PUT_I32, "GET_I32"]; +$insn_data{xio_page_len} = [32, \&PUT_I32, "GET_I32"]; +$insn_data{xio_lines_left} = [33, \&PUT_I32, "GET_I32"]; +$insn_data{xio_top_name} = [34, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{xio_top_gv} = [36, \&PUT_svindex, "GET_svindex"]; +$insn_data{xio_fmt_name} = [37, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{xio_fmt_gv} = [38, \&PUT_svindex, "GET_svindex"]; +$insn_data{xio_bottom_name} = [39, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{xio_bottom_gv} = [40, \&PUT_svindex, "GET_svindex"]; +$insn_data{xio_subprocess} = [41, \&PUT_U16, "GET_U16"]; +$insn_data{xio_type} = [42, \&PUT_U8, "GET_U8"]; +$insn_data{xio_flags} = [43, \&PUT_U8, "GET_U8"]; +$insn_data{xcv_stash} = [44, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_start} = [45, \&PUT_opindex, "GET_opindex"]; +$insn_data{xcv_root} = [46, \&PUT_opindex, "GET_opindex"]; +$insn_data{xcv_gv} = [47, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_filegv} = [48, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_depth} = [49, \&PUT_I32, "GET_I32"]; +$insn_data{xcv_padlist} = [50, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_outside} = [51, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_flags} = [52, \&PUT_U8, "GET_U8"]; +$insn_data{av_extend} = [53, \&PUT_I32, "GET_I32"]; +$insn_data{av_push} = [54, \&PUT_svindex, "GET_svindex"]; +$insn_data{xav_fill} = [55, \&PUT_I32, "GET_I32"]; +$insn_data{xav_max} = [56, \&PUT_I32, "GET_I32"]; +$insn_data{xav_flags} = [57, \&PUT_U8, "GET_U8"]; +$insn_data{xhv_riter} = [58, \&PUT_I32, "GET_I32"]; +$insn_data{xhv_name} = [59, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{hv_store} = [60, \&PUT_svindex, "GET_svindex"]; +$insn_data{sv_magic} = [61, \&PUT_U8, "GET_U8"]; +$insn_data{mg_obj} = [62, \&PUT_svindex, "GET_svindex"]; +$insn_data{mg_private} = [63, \&PUT_U16, "GET_U16"]; +$insn_data{mg_flags} = [64, \&PUT_U8, "GET_U8"]; +$insn_data{mg_pv} = [65, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{xmg_stash} = [66, \&PUT_svindex, "GET_svindex"]; +$insn_data{gv_fetchpv} = [67, \&PUT_strconst, "GET_strconst"]; +$insn_data{gv_stashpv} = [68, \&PUT_strconst, "GET_strconst"]; +$insn_data{gp_sv} = [69, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_refcnt} = [70, \&PUT_U32, "GET_U32"]; +$insn_data{gp_refcnt_add} = [71, \&PUT_I32, "GET_I32"]; +$insn_data{gp_av} = [72, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_hv} = [73, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_cv} = [74, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_filegv} = [75, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_io} = [76, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_form} = [77, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_cvgen} = [78, \&PUT_U32, "GET_U32"]; +$insn_data{gp_line} = [79, \&PUT_U16, "GET_U16"]; +$insn_data{gp_share} = [80, \&PUT_svindex, "GET_svindex"]; +$insn_data{xgv_flags} = [81, \&PUT_U8, "GET_U8"]; +$insn_data{op_next} = [82, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_sibling} = [83, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_ppaddr} = [84, \&PUT_strconst, "GET_strconst"]; +$insn_data{op_targ} = [85, \&PUT_U32, "GET_U32"]; +$insn_data{op_type} = [86, \&PUT_U16, "GET_U16"]; +$insn_data{op_seq} = [87, \&PUT_U16, "GET_U16"]; +$insn_data{op_flags} = [88, \&PUT_U8, "GET_U8"]; +$insn_data{op_private} = [89, \&PUT_U8, "GET_U8"]; +$insn_data{op_first} = [90, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_last} = [91, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_other} = [92, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_true} = [93, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_false} = [94, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_children} = [95, \&PUT_U32, "GET_U32"]; +$insn_data{op_pmreplroot} = [96, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_pmreplrootgv} = [97, \&PUT_svindex, "GET_svindex"]; +$insn_data{op_pmreplstart} = [98, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_pmnext} = [99, \&PUT_opindex, "GET_opindex"]; +$insn_data{pregcomp} = [100, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{op_pmflags} = [101, \&PUT_U16, "GET_U16"]; +$insn_data{op_pmpermflags} = [102, \&PUT_U16, "GET_U16"]; +$insn_data{op_sv} = [103, \&PUT_svindex, "GET_svindex"]; +$insn_data{op_gv} = [104, \&PUT_svindex, "GET_svindex"]; +$insn_data{op_pv} = [105, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{op_pv_tr} = [106, \&PUT_op_tr_array, "GET_op_tr_array"]; +$insn_data{op_redoop} = [107, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_nextop} = [108, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_lastop} = [109, \&PUT_opindex, "GET_opindex"]; +$insn_data{cop_label} = [110, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{cop_stash} = [111, \&PUT_svindex, "GET_svindex"]; +$insn_data{cop_filegv} = [112, \&PUT_svindex, "GET_svindex"]; +$insn_data{cop_seq} = [113, \&PUT_U32, "GET_U32"]; +$insn_data{cop_arybase} = [114, \&PUT_I32, "GET_I32"]; +$insn_data{cop_line} = [115, \&PUT_U16, "GET_U16"]; +$insn_data{main_start} = [116, \&PUT_opindex, "GET_opindex"]; +$insn_data{main_root} = [117, \&PUT_opindex, "GET_opindex"]; +$insn_data{curpad} = [118, \&PUT_svindex, "GET_svindex"]; + +my ($insn_name, $insn_data); +while (($insn_name, $insn_data) = each %insn_data) { + $insn_name[$insn_data->[0]] = $insn_name; +} +# Fill in any gaps +@insn_name = map($_ || "unused", @insn_name); + +1; + +__END__ + +=head1 NAME + +B::Asmdata - Autogenerated data about Perl ops, used to generate bytecode + +=head1 SYNOPSIS + + use Asmdata; + +=head1 DESCRIPTION + +See F. + +=head1 AUTHOR + +Malcolm Beattie, C + +=cut diff --git a/contrib/perl5/ext/B/B/Assembler.pm b/contrib/perl5/ext/B/B/Assembler.pm new file mode 100644 index 0000000..defcbdf --- /dev/null +++ b/contrib/perl5/ext/B/B/Assembler.pm @@ -0,0 +1,227 @@ +# Assembler.pm +# +# Copyright (c) 1996 Malcolm Beattie +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the README file. +package B::Assembler; +use Exporter; +use B qw(ppname); +use B::Asmdata qw(%insn_data @insn_name); + +@ISA = qw(Exporter); +@EXPORT_OK = qw(assemble_fh assemble_insn strip_comments + parse_statement uncstring); + +use strict; +my %opnumber; +my ($i, $opname); +for ($i = 0; defined($opname = ppname($i)); $i++) { + $opnumber{$opname} = $i; +} + +my ($linenum, $errors); + +sub error { + my $str = shift; + warn "$linenum: $str\n"; + $errors++; +} + +my $debug = 0; +sub debug { $debug = shift } + +# +# First define all the data conversion subs to which Asmdata will refer +# + +sub B::Asmdata::PUT_U8 { + my $arg = shift; + my $c = uncstring($arg); + if (defined($c)) { + if (length($c) != 1) { + error "argument for U8 is too long: $c"; + $c = substr($c, 0, 1); + } + } else { + $c = chr($arg); + } + return $c; +} + +sub B::Asmdata::PUT_U16 { pack("n", $_[0]) } +sub B::Asmdata::PUT_U32 { pack("N", $_[0]) } +sub B::Asmdata::PUT_I32 { pack("N", $_[0]) } +sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here + +sub B::Asmdata::PUT_strconst { + my $arg = shift; + $arg = uncstring($arg); + if (!defined($arg)) { + error "bad string constant: $arg"; + return ""; + } + if ($arg =~ s/\0//g) { + error "string constant argument contains NUL: $arg"; + } + return $arg . "\0"; +} + +sub B::Asmdata::PUT_pvcontents { + my $arg = shift; + error "extraneous argument: $arg" if defined $arg; + return ""; +} +sub B::Asmdata::PUT_PV { + my $arg = shift; + $arg = uncstring($arg); + error "bad string argument: $arg" unless defined($arg); + return pack("N", length($arg)) . $arg; +} +sub B::Asmdata::PUT_comment { + my $arg = shift; + $arg = uncstring($arg); + error "bad string argument: $arg" unless defined($arg); + if ($arg =~ s/\n//g) { + error "comment argument contains linefeed: $arg"; + } + return $arg . "\n"; +} +sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } +sub B::Asmdata::PUT_none { + my $arg = shift; + error "extraneous argument: $arg" if defined $arg; + return ""; +} +sub B::Asmdata::PUT_op_tr_array { + my $arg = shift; + my @ary = split(/\s*,\s*/, $arg); + if (@ary != 256) { + error "wrong number of arguments to op_tr_array"; + @ary = (0) x 256; + } + return pack("n256", @ary); +} +# XXX Check this works +sub B::Asmdata::PUT_IV64 { + my $arg = shift; + return pack("NN", $arg >> 32, $arg & 0xffffffff); +} + +my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a", + b => "\b", f => "\f", v => "\013"); + +sub uncstring { + my $s = shift; + $s =~ s/^"// and $s =~ s/"$// or return undef; + $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg; + return $s; +} + +sub strip_comments { + my $stmt = shift; + # Comments only allowed in instructions which don't take string arguments + $stmt =~ s{ + (?sx) # Snazzy extended regexp coming up. Also, treat + # string as a single line so .* eats \n characters. + ^\s* # Ignore leading whitespace + ( + [^"]* # A double quote '"' indicates a string argument. If we + # find a double quote, the match fails and we strip nothing. + ) + \s*\# # Any amount of whitespace plus the comment marker... + .*$ # ...which carries on to end-of-string. + }{$1}; # Keep only the instruction and optional argument. + return $stmt; +} + +sub parse_statement { + my $stmt = shift; + my ($insn, $arg) = $stmt =~ m{ + (?sx) + ^\s* # allow (but ignore) leading whitespace + (.*?) # Instruction continues up until... + (?: # ...an optional whitespace+argument group + \s+ # first whitespace. + (.*) # The argument is all the rest (newlines included). + )?$ # anchor at end-of-line + }; + if (defined($arg)) { + if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) { + $arg = hex($arg); + } elsif ($arg =~ s/^0(?=[0-7]+$)//) { + $arg = oct($arg); + } elsif ($arg =~ /^pp_/) { + $arg =~ s/\s*$//; # strip trailing whitespace + my $opnum = $opnumber{$arg}; + if (defined($opnum)) { + $arg = $opnum; + } else { + error qq(No such op type "$arg"); + $arg = 0; + } + } + } + return ($insn, $arg); +} + +sub assemble_insn { + my ($insn, $arg) = @_; + my $data = $insn_data{$insn}; + if (defined($data)) { + my ($bytecode, $putsub) = @{$data}[0, 1]; + my $argcode = &$putsub($arg); + return chr($bytecode).$argcode; + } else { + error qq(no such instruction "$insn"); + return ""; + } +} + +sub assemble_fh { + my ($fh, $out) = @_; + my ($line, $insn, $arg); + $linenum = 0; + $errors = 0; + while ($line = <$fh>) { + $linenum++; + chomp $line; + if ($debug) { + my $quotedline = $line; + $quotedline =~ s/\\/\\\\/g; + $quotedline =~ s/"/\\"/g; + &$out(assemble_insn("comment", qq("$quotedline"))); + } + $line = strip_comments($line) or next; + ($insn, $arg) = parse_statement($line); + &$out(assemble_insn($insn, $arg)); + if ($debug) { + &$out(assemble_insn("nop", undef)); + } + } + if ($errors) { + die "Assembly failed with $errors error(s)\n"; + } +} + +1; + +__END__ + +=head1 NAME + +B::Assembler - Assemble Perl bytecode + +=head1 SYNOPSIS + + use Assembler; + +=head1 DESCRIPTION + +See F. + +=head1 AUTHOR + +Malcolm Beattie, C + +=cut diff --git a/contrib/perl5/ext/B/B/Bblock.pm b/contrib/perl5/ext/B/B/Bblock.pm new file mode 100644 index 0000000..a54431b --- /dev/null +++ b/contrib/perl5/ext/B/B/Bblock.pm @@ -0,0 +1,162 @@ +package B::Bblock; +use Exporter (); +@ISA = "Exporter"; +@EXPORT_OK = qw(find_leaders); + +use B qw(peekop walkoptree walkoptree_exec + main_root main_start svref_2object); +use B::Terse; +use strict; + +my $bblock; +my @bblock_ends; + +sub mark_leader { + my $op = shift; + if ($$op) { + $bblock->{$$op} = $op; + } +} + +sub find_leaders { + my ($root, $start) = @_; + $bblock = {}; + mark_leader($start); + walkoptree($root, "mark_if_leader"); + return $bblock; +} + +# Debugging +sub walk_bblocks { + my ($root, $start) = @_; + my ($op, $lastop, $leader, $bb); + $bblock = {}; + mark_leader($start); + walkoptree($root, "mark_if_leader"); + my @leaders = values %$bblock; + while ($leader = shift @leaders) { + $lastop = $leader; + $op = $leader->next; + while ($$op && !exists($bblock->{$$op})) { + $bblock->{$$op} = $leader; + $lastop = $op; + $op = $op->next; + } + push(@bblock_ends, [$leader, $lastop]); + } + foreach $bb (@bblock_ends) { + ($leader, $lastop) = @$bb; + printf "%s .. %s\n", peekop($leader), peekop($lastop); + for ($op = $leader; $$op != $$lastop; $op = $op->next) { + printf " %s\n", peekop($op); + } + printf " %s\n", peekop($lastop); + } + print "-------\n"; + walkoptree_exec($start, "terse"); +} + +sub walk_bblocks_obj { + my $cvref = shift; + my $cv = svref_2object($cvref); + walk_bblocks($cv->ROOT, $cv->START); +} + +sub B::OP::mark_if_leader {} + +sub B::COP::mark_if_leader { + my $op = shift; + if ($op->label) { + mark_leader($op); + } +} + +sub B::LOOP::mark_if_leader { + my $op = shift; + mark_leader($op->next); + mark_leader($op->nextop); + mark_leader($op->redoop); + mark_leader($op->lastop->next); +} + +sub B::LOGOP::mark_if_leader { + my $op = shift; + my $ppaddr = $op->ppaddr; + mark_leader($op->next); + if ($ppaddr eq "pp_entertry") { + mark_leader($op->other->next); + } else { + mark_leader($op->other); + } +} + +sub B::CONDOP::mark_if_leader { + my $op = shift; + mark_leader($op->next); + mark_leader($op->true); + mark_leader($op->false); +} + +sub B::PMOP::mark_if_leader { + my $op = shift; + if ($op->ppaddr ne "pp_pushre") { + my $replroot = $op->pmreplroot; + if ($$replroot) { + mark_leader($replroot); + mark_leader($op->next); + mark_leader($op->pmreplstart); + } + } +} + +# PMOP stuff omitted + +sub compile { + my @options = @_; + if (@options) { + return sub { + my $objname; + foreach $objname (@options) { + $objname = "main::$objname" unless $objname =~ /::/; + eval "walk_bblocks_obj(\\&$objname)"; + die "walk_bblocks_obj(\\&$objname) failed: $@" if $@; + } + } + } else { + return sub { walk_bblocks(main_root, main_start) }; + } +} + +# Basic block leaders: +# Any COP (pp_nextstate) with a non-NULL label +# [The op after a pp_enter] Omit +# [The op after a pp_entersub. Don't count this one.] +# The ops pointed at by nextop, redoop and lastop->op_next of a LOOP +# The ops pointed at by op_next and op_other of a LOGOP, except +# for pp_entertry which has op_next and op_other->op_next +# The ops pointed at by op_true and op_false of a CONDOP +# The op pointed at by op_pmreplstart of a PMOP +# The op pointed at by op_other->op_pmreplstart of pp_substcont? +# [The op after a pp_return] Omit + +1; + +__END__ + +=head1 NAME + +B::Bblock - Walk basic blocks + +=head1 SYNOPSIS + + perl -MO=Bblock[,OPTIONS] foo.pl + +=head1 DESCRIPTION + +See F. + +=head1 AUTHOR + +Malcolm Beattie, C + +=cut diff --git a/contrib/perl5/ext/B/B/Bytecode.pm b/contrib/perl5/ext/B/B/Bytecode.pm new file mode 100644 index 0000000..0c5a58d --- /dev/null +++ b/contrib/perl5/ext/B/B/Bytecode.pm @@ -0,0 +1,908 @@ +# Bytecode.pm +# +# Copyright (c) 1996-1998 Malcolm Beattie +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the README file. +# +package B::Bytecode; +use strict; +use Carp; +use IO::File; + +use B qw(minus_c main_cv main_root main_start comppadlist + class peekop walkoptree svref_2object cstring walksymtable); +use B::Asmdata qw(@optype @specialsv_name); +use B::Assembler qw(assemble_fh); + +my %optype_enum; +my $i; +for ($i = 0; $i < @optype; $i++) { + $optype_enum{$optype[$i]} = $i; +} + +# Following is SVf_POK|SVp_POK +# XXX Shouldn't be hardwired +sub POK () { 0x04040000 } + +# Following is SVf_IOK|SVp_OK +# XXX Shouldn't be hardwired +sub IOK () { 0x01010000 } + +my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv); +my $assembler_pid; + +# Optimisation options. On the command line, use hyphens instead of +# underscores for compatibility with gcc-style options. We use +# underscores here because they are OK in (strict) barewords. +my ($strip_syntree, $compress_nullops, $omit_seq, $bypass_nullops); +my %optimise = (strip_syntax_tree => \$strip_syntree, + compress_nullops => \$compress_nullops, + omit_sequence_numbers => \$omit_seq, + bypass_nullops => \$bypass_nullops); + +my $nextix = 0; +my %symtable; # maps object addresses to object indices. + # Filled in at allocation (newsv/newop) time. +my %saved; # maps object addresses (for SVish classes) to "saved yet?" + # flag. Set at FOO::bytecode time usually by SV::bytecode. + # Manipulated via saved(), mark_saved(), unmark_saved(). + +my $svix = -1; # we keep track of when the sv register contains an element + # of the object table to avoid unnecessary repeated + # consecutive ldsv instructions. +my $opix = -1; # Ditto for the op register. + +sub ldsv { + my $ix = shift; + if ($ix != $svix) { + print "ldsv $ix\n"; + $svix = $ix; + } +} + +sub stsv { + my $ix = shift; + print "stsv $ix\n"; + $svix = $ix; +} + +sub set_svix { + $svix = shift; +} + +sub ldop { + my $ix = shift; + if ($ix != $opix) { + print "ldop $ix\n"; + $opix = $ix; + } +} + +sub stop { + my $ix = shift; + print "stop $ix\n"; + $opix = $ix; +} + +sub set_opix { + $opix = shift; +} + +sub pvstring { + my $str = shift; + if (defined($str)) { + return cstring($str . "\0"); + } else { + return '""'; + } +} + +sub saved { $saved{${$_[0]}} } +sub mark_saved { $saved{${$_[0]}} = 1 } +sub unmark_saved { $saved{${$_[0]}} = 0 } + +sub debug { $debug_bc = shift } + +sub B::OBJECT::nyi { + my $obj = shift; + warn sprintf("bytecode save method for %s (0x%x) not yet implemented\n", + class($obj), $$obj); +} + +# +# objix may stomp on the op register (for op objects) +# or the sv register (for SV objects) +# +sub B::OBJECT::objix { + my $obj = shift; + my $ix = $symtable{$$obj}; + if (defined($ix)) { + return $ix; + } else { + $obj->newix($nextix); + return $symtable{$$obj} = $nextix++; + } +} + +sub B::SV::newix { + my ($sv, $ix) = @_; + printf "newsv %d\t# %s\n", $sv->FLAGS & 0xf, class($sv); + stsv($ix); +} + +sub B::GV::newix { + my ($gv, $ix) = @_; + my $gvname = $gv->NAME; + my $name = cstring($gv->STASH->NAME . "::" . $gvname); + print "gv_fetchpv $name\n"; + stsv($ix); +} + +sub B::HV::newix { + my ($hv, $ix) = @_; + my $name = $hv->NAME; + if ($name) { + # It's a stash + printf "gv_stashpv %s\n", cstring($name); + stsv($ix); + } else { + # It's an ordinary HV. Fall back to ordinary newix method + $hv->B::SV::newix($ix); + } +} + +sub B::SPECIAL::newix { + my ($sv, $ix) = @_; + # Special case. $$sv is not the address of the SV but an + # index into svspecialsv_list. + printf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv]; + stsv($ix); +} + +sub B::OP::newix { + my ($op, $ix) = @_; + my $class = class($op); + my $typenum = $optype_enum{$class}; + croak "OP::newix: can't understand class $class" unless defined($typenum); + print "newop $typenum\t# $class\n"; + stop($ix); +} + +sub B::OP::walkoptree_debug { + my $op = shift; + warn(sprintf("walkoptree: %s\n", peekop($op))); +} + +sub B::OP::bytecode { + my $op = shift; + my $next = $op->next; + my $nextix; + my $sibix = $op->sibling->objix; + my $ix = $op->objix; + my $type = $op->type; + + if ($bypass_nullops) { + $next = $next->next while $$next && $next->type == 0; + } + $nextix = $next->objix; + + printf "# %s\n", peekop($op) if $debug_bc; + ldop($ix); + print "op_next $nextix\n"; + print "op_sibling $sibix\n" unless $strip_syntree; + printf "op_type %s\t# %d\n", $op->ppaddr, $type; + printf("op_seq %d\n", $op->seq) unless $omit_seq; + if ($type || !$compress_nullops) { + printf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n", + $op->targ, $op->flags, $op->private; + } +} + +sub B::UNOP::bytecode { + my $op = shift; + my $firstix = $op->first->objix; + $op->B::OP::bytecode; + if (($op->type || !$compress_nullops) && !$strip_syntree) { + print "op_first $firstix\n"; + } +} + +sub B::LOGOP::bytecode { + my $op = shift; + my $otherix = $op->other->objix; + $op->B::UNOP::bytecode; + print "op_other $otherix\n"; +} + +sub B::SVOP::bytecode { + my $op = shift; + my $sv = $op->sv; + my $svix = $sv->objix; + $op->B::OP::bytecode; + print "op_sv $svix\n"; + $sv->bytecode; +} + +sub B::GVOP::bytecode { + my $op = shift; + my $gv = $op->gv; + my $gvix = $gv->objix; + $op->B::OP::bytecode; + print "op_gv $gvix\n"; + $gv->bytecode; +} + +sub B::PVOP::bytecode { + my $op = shift; + my $pv = $op->pv; + $op->B::OP::bytecode; + # + # This would be easy except that OP_TRANS uses a PVOP to store an + # endian-dependent array of 256 shorts instead of a plain string. + # + if ($op->ppaddr eq "pp_trans") { + my @shorts = unpack("s256", $pv); # assembler handles endianness + print "op_pv_tr ", join(",", @shorts), "\n"; + } else { + printf "newpv %s\nop_pv\n", pvstring($pv); + } +} + +sub B::BINOP::bytecode { + my $op = shift; + my $lastix = $op->last->objix; + $op->B::UNOP::bytecode; + if (($op->type || !$compress_nullops) && !$strip_syntree) { + print "op_last $lastix\n"; + } +} + +sub B::CONDOP::bytecode { + my $op = shift; + my $trueix = $op->true->objix; + my $falseix = $op->false->objix; + $op->B::UNOP::bytecode; + print "op_true $trueix\nop_false $falseix\n"; +} + +sub B::LISTOP::bytecode { + my $op = shift; + my $children = $op->children; + $op->B::BINOP::bytecode; + if (($op->type || !$compress_nullops) && !$strip_syntree) { + print "op_children $children\n"; + } +} + +sub B::LOOP::bytecode { + my $op = shift; + my $redoopix = $op->redoop->objix; + my $nextopix = $op->nextop->objix; + my $lastopix = $op->lastop->objix; + $op->B::LISTOP::bytecode; + print "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n"; +} + +sub B::COP::bytecode { + my $op = shift; + my $stash = $op->stash; + my $stashix = $stash->objix; + my $filegv = $op->filegv; + my $filegvix = $filegv->objix; + my $line = $op->line; + if ($debug_bc) { + printf "# line %s:%d\n", $filegv->SV->PV, $line; + } + $op->B::OP::bytecode; + printf <<"EOT", pvstring($op->label), $op->cop_seq, $op->arybase; +newpv %s +cop_label +cop_stash $stashix +cop_seq %d +cop_filegv $filegvix +cop_arybase %d +cop_line $line +EOT + $filegv->bytecode; + $stash->bytecode; +} + +sub B::PMOP::bytecode { + my $op = shift; + my $replroot = $op->pmreplroot; + my $replrootix = $replroot->objix; + my $replstartix = $op->pmreplstart->objix; + my $ppaddr = $op->ppaddr; + # pmnext is corrupt in some PMOPs (see misc.t for example) + #my $pmnextix = $op->pmnext->objix; + + if ($$replroot) { + # OP_PUSHRE (a mutated version of OP_MATCH for the regexp + # argument to a split) stores a GV in op_pmreplroot instead + # of a substitution syntax tree. We don't want to walk that... + if ($ppaddr eq "pp_pushre") { + $replroot->bytecode; + } else { + walkoptree($replroot, "bytecode"); + } + } + $op->B::LISTOP::bytecode; + if ($ppaddr eq "pp_pushre") { + printf "op_pmreplrootgv $replrootix\n"; + } else { + print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n"; + } + my $re = pvstring($op->precomp); + # op_pmnext omitted since a perl bug means it's sometime corrupt + printf <<"EOT", $op->pmflags, $op->pmpermflags; +op_pmflags 0x%x +op_pmpermflags 0x%x +newpv $re +pregcomp +EOT +} + +sub B::SV::bytecode { + my $sv = shift; + return if saved($sv); + my $ix = $sv->objix; + my $refcnt = $sv->REFCNT; + my $flags = sprintf("0x%x", $sv->FLAGS); + ldsv($ix); + print "sv_refcnt $refcnt\nsv_flags $flags\n"; + mark_saved($sv); +} + +sub B::PV::bytecode { + my $sv = shift; + return if saved($sv); + $sv->B::SV::bytecode; + printf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK; +} + +sub B::IV::bytecode { + my $sv = shift; + return if saved($sv); + my $iv = $sv->IVX; + $sv->B::SV::bytecode; + printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; +} + +sub B::NV::bytecode { + my $sv = shift; + return if saved($sv); + $sv->B::SV::bytecode; + printf "xnv %s\n", $sv->NVX; +} + +sub B::RV::bytecode { + my $sv = shift; + return if saved($sv); + my $rv = $sv->RV; + my $rvix = $rv->objix; + $rv->bytecode; + $sv->B::SV::bytecode; + print "xrv $rvix\n"; +} + +sub B::PVIV::bytecode { + my $sv = shift; + return if saved($sv); + my $iv = $sv->IVX; + $sv->B::PV::bytecode; + printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; +} + +sub B::PVNV::bytecode { + my ($sv, $flag) = @_; + # The $flag argument is passed through PVMG::bytecode by BM::bytecode + # and AV::bytecode and indicates special handling. $flag = 1 is used by + # BM::bytecode and means that we should ensure we save the whole B-M + # table. It consists of 257 bytes (256 char array plus a final \0) + # which follow the ordinary PV+\0 and the 257 bytes are *not* reflected + # in SvCUR. $flag = 2 is used by AV::bytecode and means that we only + # call SV::bytecode instead of saving PV and calling NV::bytecode since + # PV/NV/IV stuff is different for AVs. + return if saved($sv); + if ($flag == 2) { + $sv->B::SV::bytecode; + } else { + my $pv = $sv->PV; + $sv->B::IV::bytecode; + printf "xnv %s\n", $sv->NVX; + if ($flag == 1) { + $pv .= "\0" . $sv->TABLE; + printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257; + } else { + printf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK; + } + } +} + +sub B::PVMG::bytecode { + my ($sv, $flag) = @_; + # See B::PVNV::bytecode for an explanation of $flag. + return if saved($sv); + # XXX We assume SvSTASH is already saved and don't save it later ourselves + my $stashix = $sv->SvSTASH->objix; + my @mgchain = $sv->MAGIC; + my (@mgobjix, $mg); + # + # We need to traverse the magic chain and get objix for each OBJ + # field *before* we do B::PVNV::bytecode since objix overwrites + # the sv register. However, we need to write the magic-saving + # bytecode *after* B::PVNV::bytecode since sv isn't initialised + # to refer to $sv until then. + # + @mgobjix = map($_->OBJ->objix, @mgchain); + $sv->B::PVNV::bytecode($flag); + print "xmg_stash $stashix\n"; + foreach $mg (@mgchain) { + printf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n", + cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR); + } +} + +sub B::PVLV::bytecode { + my $sv = shift; + return if saved($sv); + $sv->B::PVMG::bytecode; + printf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE); +xlv_targoff %d +xlv_targlen %d +xlv_type %s +EOT +} + +sub B::BM::bytecode { + my $sv = shift; + return if saved($sv); + # See PVNV::bytecode for an explanation of what the argument does + $sv->B::PVMG::bytecode(1); + printf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n", + $sv->USEFUL, $sv->PREVIOUS, $sv->RARE; +} + +sub B::GV::bytecode { + my $gv = shift; + return if saved($gv); + my $ix = $gv->objix; + mark_saved($gv); + my $gvname = $gv->NAME; + my $name = cstring($gv->STASH->NAME . "::" . $gvname); + my $egv = $gv->EGV; + my $egvix = $egv->objix; + ldsv($ix); + printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS, $gv->LINE; +sv_flags 0x%x +xgv_flags 0x%x +gp_line %d +EOT + my $refcnt = $gv->REFCNT; + printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1; + my $gvrefcnt = $gv->GvREFCNT; + printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1; + if ($gvrefcnt > 1 && $ix != $egvix) { + print "gp_share $egvix\n"; + } else { + if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) { + my $i; + my @subfield_names = qw(SV AV HV CV FILEGV FORM IO); + my @subfields = map($gv->$_(), @subfield_names); + my @ixes = map($_->objix, @subfields); + # Reset sv register for $gv + ldsv($ix); + for ($i = 0; $i < @ixes; $i++) { + printf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; + } + # Now save all the subfields + my $sv; + foreach $sv (@subfields) { + $sv->bytecode; + } + } + } +} + +sub B::HV::bytecode { + my $hv = shift; + return if saved($hv); + mark_saved($hv); + my $name = $hv->NAME; + my $ix = $hv->objix; + if (!$name) { + # It's an ordinary HV. Stashes have NAME set and need no further + # saving beyond the gv_stashpv that $hv->objix already ensures. + my @contents = $hv->ARRAY; + my ($i, @ixes); + for ($i = 1; $i < @contents; $i += 2) { + push(@ixes, $contents[$i]->objix); + } + for ($i = 1; $i < @contents; $i += 2) { + $contents[$i]->bytecode; + } + ldsv($ix); + for ($i = 0; $i < @contents; $i += 2) { + printf("newpv %s\nhv_store %d\n", + pvstring($contents[$i]), $ixes[$i / 2]); + } + printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS; + } +} + +sub B::AV::bytecode { + my $av = shift; + return if saved($av); + my $ix = $av->objix; + my $fill = $av->FILL; + my $max = $av->MAX; + my (@array, @ixes); + if ($fill > -1) { + @array = $av->ARRAY; + @ixes = map($_->objix, @array); + my $sv; + foreach $sv (@array) { + $sv->bytecode; + } + } + # See PVNV::bytecode for the meaning of the flag argument of 2. + $av->B::PVMG::bytecode(2); + # Recover sv register and set AvMAX and AvFILL to -1 (since we + # create an AV with NEWSV and SvUPGRADE rather than doing newAV + # which is what sets AvMAX and AvFILL. + ldsv($ix); + printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS; + if ($fill > -1) { + my $elix; + foreach $elix (@ixes) { + print "av_push $elix\n"; + } + } else { + if ($max > -1) { + print "av_extend $max\n"; + } + } +} + +sub B::CV::bytecode { + my $cv = shift; + return if saved($cv); + my $ix = $cv->objix; + $cv->B::PVMG::bytecode; + my $i; + my @subfield_names = qw(ROOT START STASH GV FILEGV PADLIST OUTSIDE); + my @subfields = map($cv->$_(), @subfield_names); + my @ixes = map($_->objix, @subfields); + # Save OP tree from CvROOT (first element of @subfields) + my $root = shift @subfields; + if ($$root) { + walkoptree($root, "bytecode"); + } + # Reset sv register for $cv (since above ->objix calls stomped on it) + ldsv($ix); + for ($i = 0; $i < @ixes; $i++) { + printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; + } + printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->FLAGS; + # Now save all the subfields (except for CvROOT which was handled + # above) and CvSTART (now the initial element of @subfields). + shift @subfields; # bye-bye CvSTART + my $sv; + foreach $sv (@subfields) { + $sv->bytecode; + } +} + +sub B::IO::bytecode { + my $io = shift; + return if saved($io); + my $ix = $io->objix; + my $top_gv = $io->TOP_GV; + my $top_gvix = $top_gv->objix; + my $fmt_gv = $io->FMT_GV; + my $fmt_gvix = $fmt_gv->objix; + my $bottom_gv = $io->BOTTOM_GV; + my $bottom_gvix = $bottom_gv->objix; + + $io->B::PVMG::bytecode; + ldsv($ix); + print "xio_top_gv $top_gvix\n"; + print "xio_fmt_gv $fmt_gvix\n"; + print "xio_bottom_gv $bottom_gvix\n"; + my $field; + foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) { + printf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field); + } + foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) { + printf "xio_%s %d\n", lc($field), $io->$field(); + } + printf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS; + $top_gv->bytecode; + $fmt_gv->bytecode; + $bottom_gv->bytecode; +} + +sub B::SPECIAL::bytecode { + # nothing extra needs doing +} + +sub bytecompile_object { + my $sv; + foreach $sv (@_) { + svref_2object($sv)->bytecode; + } +} + +sub B::GV::bytecodecv { + my $gv = shift; + my $cv = $gv->CV; + if ($$cv && !saved($cv)) { + if ($debug_cv) { + warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", + $gv->STASH->NAME, $gv->NAME, $$cv, $$gv); + } + $gv->bytecode; + } +} + +sub bytecompile_main { + my $curpad = (comppadlist->ARRAY)[1]; + my $curpadix = $curpad->objix; + $curpad->bytecode; + walkoptree(main_root, "bytecode"); + warn "done main program, now walking symbol table\n" if $debug_bc; + my ($pack, %exclude); + foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS strict vars + FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol + SelectSaver blib Cwd)) + { + $exclude{$pack."::"} = 1; + } + no strict qw(vars refs); + walksymtable(\%{"main::"}, "bytecodecv", sub { + warn "considering $_[0]\n" if $debug_bc; + return !defined($exclude{$_[0]}); + }); + if (!$module_only) { + printf "main_root %d\n", main_root->objix; + printf "main_start %d\n", main_start->objix; + printf "curpad $curpadix\n"; + # XXX Do min_intro_pending and max_intro_pending matter? + } +} + +sub prepare_assemble { + my $newfh = IO::File->new_tmpfile; + select($newfh); + binmode $newfh; + return $newfh; +} + +sub do_assemble { + my $fh = shift; + seek($fh, 0, 0); # rewind the temporary file + assemble_fh($fh, sub { print OUT @_ }); +} + +sub compile { + my @options = @_; + my ($option, $opt, $arg); + open(OUT, ">&STDOUT"); + binmode OUT; + select(OUT); + OPTION: + while ($option = shift @options) { + if ($option =~ /^-(.)(.*)/) { + $opt = $1; + $arg = $2; + } else { + unshift @options, $option; + last OPTION; + } + if ($opt eq "-" && $arg eq "-") { + shift @options; + last OPTION; + } elsif ($opt eq "o") { + $arg ||= shift @options; + open(OUT, ">$arg") or return "$arg: $!\n"; + binmode OUT; + } elsif ($opt eq "D") { + $arg ||= shift @options; + foreach $arg (split(//, $arg)) { + if ($arg eq "b") { + $| = 1; + debug(1); + } elsif ($arg eq "o") { + B->debug(1); + } elsif ($arg eq "a") { + B::Assembler::debug(1); + } elsif ($arg eq "C") { + $debug_cv = 1; + } + } + } elsif ($opt eq "v") { + $verbose = 1; + } elsif ($opt eq "m") { + $module_only = 1; + } elsif ($opt eq "S") { + $no_assemble = 1; + } elsif ($opt eq "f") { + $arg ||= shift @options; + my $value = $arg !~ s/^no-//; + $arg =~ s/-/_/g; + my $ref = $optimise{$arg}; + if (defined($ref)) { + $$ref = $value; + } else { + warn qq(ignoring unknown optimisation option "$arg"\n); + } + } elsif ($opt eq "O") { + $arg = 1 if $arg eq ""; + my $ref; + foreach $ref (values %optimise) { + $$ref = 0; + } + if ($arg >= 6) { + $strip_syntree = 1; + } + if ($arg >= 2) { + $bypass_nullops = 1; + } + if ($arg >= 1) { + $compress_nullops = 1; + $omit_seq = 1; + } + } + } + if (@options) { + return sub { + my $objname; + my $newfh; + $newfh = prepare_assemble() unless $no_assemble; + foreach $objname (@options) { + eval "bytecompile_object(\\$objname)"; + } + do_assemble($newfh) unless $no_assemble; + } + } else { + return sub { + my $newfh; + $newfh = prepare_assemble() unless $no_assemble; + bytecompile_main(); + do_assemble($newfh) unless $no_assemble; + } + } +} + +1; + +__END__ + +=head1 NAME + +B::Bytecode - Perl compiler's bytecode backend + +=head1 SYNOPSIS + + perl -MO=Bytecode[,OPTIONS] foo.pl + +=head1 DESCRIPTION + +This compiler backend takes Perl source and generates a +platform-independent bytecode encapsulating code to load the +internal structures perl uses to run your program. When the +generated bytecode is loaded in, your program is ready to run, +reducing the time which perl would have taken to load and parse +your program into its internal semi-compiled form. That means that +compiling with this backend will not help improve the runtime +execution speed of your program but may improve the start-up time. +Depending on the environment in which your program runs this may +or may not be a help. + +The resulting bytecode can be run with a special byteperl executable +or (for non-main programs) be loaded via the C function +in the F module. + +=head1 OPTIONS + +If there are any non-option arguments, they are taken to be names of +objects to be saved (probably doesn't work properly yet). Without +extra arguments, it saves the main program. + +=over 4 + +=item B<-ofilename> + +Output to filename instead of STDOUT. + +=item B<--> + +Force end of options. + +=item B<-f> + +Force optimisations on or off one at a time. Each can be preceded +by B to turn the option off (e.g. B<-fno-compress-nullops>). + +=item B<-fcompress-nullops> + +Only fills in the necessary fields of ops which have +been optimised away by perl's internal compiler. + +=item B<-fomit-sequence-numbers> + +Leaves out code to fill in the op_seq field of all ops +which is only used by perl's internal compiler. + +=item B<-fbypass-nullops> + +If op->op_next ever points to a NULLOP, replaces the op_next field +with the first non-NULLOP in the path of execution. + +=item B<-fstrip-syntax-tree> + +Leaves out code to fill in the pointers which link the internal syntax +tree together. They're not needed at run-time but leaving them out +will make it impossible to recompile or disassemble the resulting +program. It will also stop C statements from working. + +=item B<-On> + +Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. +B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>. +B<-O6> adds B<-fstrip-syntax-tree>. + +=item B<-D> + +Debug options (concatenated or separate flags like C). + +=item B<-Do> + +Prints each OP as it's processed. + +=item B<-Db> + +Print debugging information about bytecompiler progress. + +=item B<-Da> + +Tells the (bytecode) assembler to include source assembler lines +in its output as bytecode comments. + +=item B<-DC> + +Prints each CV taken from the final symbol tree walk. + +=item B<-S> + +Output (bytecode) assembler source rather than piping it +through the assembler and outputting bytecode. + +=item B<-m> + +Compile as a module rather than a standalone program. Currently this +just means that the bytecodes for initialising C, +C and C are omitted. + +=back + +=head1 EXAMPLES + + perl -MO=Bytecode,-O6,-o,foo.plc foo.pl + + perl -MO=Bytecode,-S foo.pl > foo.S + assemble foo.S > foo.plc + byteperl foo.plc + + perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm + +=head1 BUGS + +Plenty. Current status: experimental. + +=head1 AUTHOR + +Malcolm Beattie, C + +=cut diff --git a/contrib/perl5/ext/B/B/C.pm b/contrib/perl5/ext/B/B/C.pm new file mode 100644 index 0000000..0b7d6eb --- /dev/null +++ b/contrib/perl5/ext/B/B/C.pm @@ -0,0 +1,1319 @@ +# C.pm +# +# Copyright (c) 1996, 1997, 1998 Malcolm Beattie +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the README file. +# +package B::C; +use Exporter (); +@ISA = qw(Exporter); +@EXPORT_OK = qw(output_all output_boilerplate output_main + init_sections set_callback save_unused_subs objsym); + +use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop + class cstring cchar svref_2object compile_stats comppadlist hash + threadsv_names); +use B::Asmdata qw(@specialsv_name); + +use FileHandle; +use Carp; +use strict; + +my $hv_index = 0; +my $gv_index = 0; +my $re_index = 0; +my $pv_index = 0; +my $anonsub_index = 0; + +my %symtable; +my $warn_undefined_syms; +my $verbose; +my @unused_sub_packages; +my $nullop_count; +my $pv_copy_on_grow; +my ($debug_cops, $debug_av, $debug_cv, $debug_mg); + +my @threadsv_names; +BEGIN { + @threadsv_names = threadsv_names(); +} + +# Code sections +my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, $cvopsect, + $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect, + $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect, + $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, + $xrvsect, $xpvbmsect, $xpviosect); + +sub walk_and_save_optree; +my $saveoptree_callback = \&walk_and_save_optree; +sub set_callback { $saveoptree_callback = shift } +sub saveoptree { &$saveoptree_callback(@_) } + +sub walk_and_save_optree { + my ($name, $root, $start) = @_; + walkoptree($root, "save"); + return objsym($start); +} + +# Current workaround/fix for op_free() trying to free statically +# defined OPs is to set op_seq = -1 and check for that in op_free(). +# Instead of hardwiring -1 in place of $op->seq, we use $op_seq +# so that it can be changed back easily if necessary. In fact, to +# stop compilers from moaning about a U16 being initialised with an +# uncast -1 (the printf format is %d so we can't tweak it), we have +# to "know" that op_seq is a U16 and use 65535. Ugh. +my $op_seq = 65535; + +sub AVf_REAL () { 1 } + +# XXX This shouldn't really be hardcoded here but it saves +# looking up the name of every BASEOP in B::OP +sub OP_THREADSV () { 345 } + +sub savesym { + my ($obj, $value) = @_; + my $sym = sprintf("s\\_%x", $$obj); + $symtable{$sym} = $value; +} + +sub objsym { + my $obj = shift; + return $symtable{sprintf("s\\_%x", $$obj)}; +} + +sub getsym { + my $sym = shift; + my $value; + + return 0 if $sym eq "sym_0"; # special case + $value = $symtable{$sym}; + if (defined($value)) { + return $value; + } else { + warn "warning: undefined symbol $sym\n" if $warn_undefined_syms; + return "UNUSED"; + } +} + +sub savepv { + my $pv = shift; + my $pvsym = 0; + my $pvmax = 0; + if ($pv_copy_on_grow) { + my $cstring = cstring($pv); + if ($cstring ne "0") { # sic + $pvsym = sprintf("pv%d", $pv_index++); + $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring)); + } + } else { + $pvmax = length($pv) + 1; + } + return ($pvsym, $pvmax); +} + +sub B::OP::save { + my ($op, $level) = @_; + my $type = $op->type; + $nullop_count++ unless $type; + if ($type == OP_THREADSV) { + # saves looking up ppaddr but it's a bit naughty to hard code this + $init->add(sprintf("(void)find_threadsv(%s);", + cstring($threadsv_names[$op->targ]))); + } + $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x", + ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, + $type, $op_seq, $op->flags, $op->private)); + savesym($op, sprintf("&op_list[%d]", $opsect->index)); +} + +sub B::FAKEOP::new { + my ($class, %objdata) = @_; + bless \%objdata, $class; +} + +sub B::FAKEOP::save { + my ($op, $level) = @_; + $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x", + $op->next, $op->sibling, $op->ppaddr, $op->targ, + $op->type, $op_seq, $op->flags, $op->private)); + return sprintf("&op_list[%d]", $opsect->index); +} + +sub B::FAKEOP::next { $_[0]->{"next"} || 0 } +sub B::FAKEOP::type { $_[0]->{type} || 0} +sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 } +sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 } +sub B::FAKEOP::targ { $_[0]->{targ} || 0 } +sub B::FAKEOP::flags { $_[0]->{flags} || 0 } +sub B::FAKEOP::private { $_[0]->{private} || 0 } + +sub B::UNOP::save { + my ($op, $level) = @_; + $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x", + ${$op->next}, ${$op->sibling}, $op->ppaddr, + $op->targ, $op->type, $op_seq, $op->flags, + $op->private, ${$op->first})); + savesym($op, sprintf("(OP*)&unop_list[%d]", $unopsect->index)); +} + +sub B::BINOP::save { + my ($op, $level) = @_; + $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", + ${$op->next}, ${$op->sibling}, $op->ppaddr, + $op->targ, $op->type, $op_seq, $op->flags, + $op->private, ${$op->first}, ${$op->last})); + savesym($op, sprintf("(OP*)&binop_list[%d]", $binopsect->index)); +} + +sub B::LISTOP::save { + my ($op, $level) = @_; + $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u", + ${$op->next}, ${$op->sibling}, $op->ppaddr, + $op->targ, $op->type, $op_seq, $op->flags, + $op->private, ${$op->first}, ${$op->last}, + $op->children)); + savesym($op, sprintf("(OP*)&listop_list[%d]", $listopsect->index)); +} + +sub B::LOGOP::save { + my ($op, $level) = @_; + $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", + ${$op->next}, ${$op->sibling}, $op->ppaddr, + $op->targ, $op->type, $op_seq, $op->flags, + $op->private, ${$op->first}, ${$op->other})); + savesym($op, sprintf("(OP*)&logop_list[%d]", $logopsect->index)); +} + +sub B::CONDOP::save { + my ($op, $level) = @_; + $condopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x", + ${$op->next}, ${$op->sibling}, $op->ppaddr, + $op->targ, $op->type, $op_seq, $op->flags, + $op->private, ${$op->first}, ${$op->true}, + ${$op->false})); + savesym($op, sprintf("(OP*)&condop_list[%d]", $condopsect->index)); +} + +sub B::LOOP::save { + my ($op, $level) = @_; + #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n", + # peekop($op->redoop), peekop($op->nextop), + # peekop($op->lastop)); # debug + $loopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x", + ${$op->next}, ${$op->sibling}, $op->ppaddr, + $op->targ, $op->type, $op_seq, $op->flags, + $op->private, ${$op->first}, ${$op->last}, + $op->children, ${$op->redoop}, ${$op->nextop}, + ${$op->lastop})); + savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index)); +} + +sub B::PVOP::save { + my ($op, $level) = @_; + $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s", + ${$op->next}, ${$op->sibling}, $op->ppaddr, + $op->targ, $op->type, $op_seq, $op->flags, + $op->private, cstring($op->pv))); + savesym($op, sprintf("(OP*)&pvop_list[%d]", $pvopsect->index)); +} + +sub B::SVOP::save { + my ($op, $level) = @_; + my $svsym = $op->sv->save; + $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s", + ${$op->next}, ${$op->sibling}, $op->ppaddr, + $op->targ, $op->type, $op_seq, $op->flags, + $op->private, "(SV*)$svsym")); + savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index)); +} + +sub B::GVOP::save { + my ($op, $level) = @_; + my $gvsym = $op->gv->save; + $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv", + ${$op->next}, ${$op->sibling}, $op->ppaddr, + $op->targ, $op->type, $op_seq, $op->flags, + $op->private)); + $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym)); + savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->index)); +} + +sub B::COP::save { + my ($op, $level) = @_; + my $gvsym = $op->filegv->save; + my $stashsym = $op->stash->save; + warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV) + if $debug_cops; + $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u", + ${$op->next}, ${$op->sibling}, $op->ppaddr, + $op->targ, $op->type, $op_seq, $op->flags, + $op->private, cstring($op->label), $op->cop_seq, + $op->arybase, $op->line)); + my $copix = $copsect->index; + $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym), + sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym)); + savesym($op, "(OP*)&cop_list[$copix]"); +} + +sub B::PMOP::save { + my ($op, $level) = @_; + my $replroot = $op->pmreplroot; + my $replstart = $op->pmreplstart; + my $replrootfield = sprintf("s\\_%x", $$replroot); + my $replstartfield = sprintf("s\\_%x", $$replstart); + my $gvsym; + my $ppaddr = $op->ppaddr; + if ($$replroot) { + # OP_PUSHRE (a mutated version of OP_MATCH for the regexp + # argument to a split) stores a GV in op_pmreplroot instead + # of a substitution syntax tree. We don't want to walk that... + if ($ppaddr eq "pp_pushre") { + $gvsym = $replroot->save; +# warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug + $replrootfield = 0; + } else { + $replstartfield = saveoptree("*ignore*", $replroot, $replstart); + } + } + # pmnext handling is broken in perl itself, I think. Bad op_pmnext + # fields aren't noticed in perl's runtime (unless you try reset) but we + # segfault when trying to dereference it to find op->op_pmnext->op_type + $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x", + ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ, + $op->type, $op_seq, $op->flags, $op->private, + ${$op->first}, ${$op->last}, $op->children, + $replrootfield, $replstartfield, + $op->pmflags, $op->pmpermflags,)); + my $pm = sprintf("pmop_list[%d]", $pmopsect->index); + my $re = $op->precomp; + if (defined($re)) { + my $resym = sprintf("re%d", $re_index++); + $decl->add(sprintf("static char *$resym = %s;", cstring($re))); + $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);", + length($re))); + } + if ($gvsym) { + $init->add("$pm.op_pmreplroot = (OP*)$gvsym;"); + } + savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index)); +} + +sub B::SPECIAL::save { + my ($sv) = @_; + # special case: $$sv is not the address but an index into specialsv_list +# warn "SPECIAL::save specialsv $$sv\n"; # debug + my $sym = $specialsv_name[$$sv]; + if (!defined($sym)) { + confess "unknown specialsv index $$sv passed to B::SPECIAL::save"; + } + return $sym; +} + +sub B::OBJECT::save {} + +sub B::NULL::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; +# warn "Saving SVt_NULL SV\n"; # debug + # debug + #if ($$sv == 0) { + # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n"; + #} + $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS)); + return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); +} + +sub B::IV::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; + $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX)); + $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x", + $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); +} + +sub B::NV::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; + $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX)); + $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", + $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); +} + +sub B::PVLV::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; + my $pv = $sv->PV; + my $len = length($pv); + my ($pvsym, $pvmax) = savepv($pv); + my ($lvtarg, $lvtarg_sym); + $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s", + $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX, + $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE))); + $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x", + $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + if (!$pv_copy_on_grow) { + $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);", + $xpvlvsect->index, cstring($pv), $len)); + } + $sv->save_magic; + return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); +} + +sub B::PVIV::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; + my $pv = $sv->PV; + my $len = length($pv); + my ($pvsym, $pvmax) = savepv($pv); + $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX)); + $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x", + $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + if (!$pv_copy_on_grow) { + $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);", + $xpvivsect->index, cstring($pv), $len)); + } + return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); +} + +sub B::PVNV::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; + my $pv = $sv->PV; + my $len = length($pv); + my ($pvsym, $pvmax) = savepv($pv); + $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s", + $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX)); + $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", + $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + if (!$pv_copy_on_grow) { + $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);", + $xpvnvsect->index, cstring($pv), $len)); + } + return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); +} + +sub B::BM::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; + my $pv = $sv->PV . "\0" . $sv->TABLE; + my $len = length($pv); + $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x", + $len, $len + 258, $sv->IVX, $sv->NVX, + $sv->USEFUL, $sv->PREVIOUS, $sv->RARE)); + $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x", + $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $sv->save_magic; + $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);", + $xpvbmsect->index, cstring($pv), $len), + sprintf("xpvbm_list[%d].xpv_cur = %u;", + $xpvbmsect->index, $len - 257)); + return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); +} + +sub B::PV::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; + my $pv = $sv->PV; + my $len = length($pv); + my ($pvsym, $pvmax) = savepv($pv); + $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax)); + $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x", + $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + if (!$pv_copy_on_grow) { + $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);", + $xpvsect->index, cstring($pv), $len)); + } + return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); +} + +sub B::PVMG::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; + my $pv = $sv->PV; + my $len = length($pv); + my ($pvsym, $pvmax) = savepv($pv); + $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0", + $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX)); + $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x", + $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + if (!$pv_copy_on_grow) { + $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);", + $xpvmgsect->index, cstring($pv), $len)); + } + $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); + $sv->save_magic; + return $sym; +} + +sub B::PVMG::save_magic { + my ($sv) = @_; + #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug + my $stash = $sv->SvSTASH; + if ($$stash) { + warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash) + if $debug_mg; + # XXX Hope stash is already going to be saved. + $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash)); + } + my @mgchain = $sv->MAGIC; + my ($mg, $type, $obj, $ptr); + foreach $mg (@mgchain) { + $type = $mg->TYPE; + $obj = $mg->OBJ; + $ptr = $mg->PTR; + my $len = defined($ptr) ? length($ptr) : 0; + if ($debug_mg) { + warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n", + class($sv), $$sv, class($obj), $$obj, + cchar($type), cstring($ptr)); + } + $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);", + $$sv, $$obj, cchar($type),cstring($ptr),$len)); + } +} + +sub B::RV::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; + $xrvsect->add($sv->RV->save); + $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x", + $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); +} + +sub try_autoload { + my ($cvstashname, $cvname) = @_; + warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname); + # Handle AutoLoader classes explicitly. Any more general AUTOLOAD + # use should be handled by the class itself. + no strict 'refs'; + my $isa = \@{"$cvstashname\::ISA"}; + if (grep($_ eq "AutoLoader", @$isa)) { + warn "Forcing immediate load of sub derived from AutoLoader\n"; + # Tweaked version of AutoLoader::AUTOLOAD + my $dir = $cvstashname; + $dir =~ s(::)(/)g; + eval { require "auto/$dir/$cvname.al" }; + if ($@) { + warn qq(failed require "auto/$dir/$cvname.al": $@\n); + return 0; + } else { + return 1; + } + } +} + +sub B::CV::save { + my ($cv) = @_; + my $sym = objsym($cv); + if (defined($sym)) { +# warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug + return $sym; + } + # Reserve a place in svsect and xpvcvsect and record indices + my $sv_ix = $svsect->index + 1; + $svsect->add("svix$sv_ix"); + my $xpvcv_ix = $xpvcvsect->index + 1; + $xpvcvsect->add("xpvcvix$xpvcv_ix"); + # Save symbol now so that GvCV() doesn't recurse back to us via CvGV() + $sym = savesym($cv, "&sv_list[$sv_ix]"); + warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv; + my $gv = $cv->GV; + my $cvstashname = $gv->STASH->NAME; + my $cvname = $gv->NAME; + my $root = $cv->ROOT; + my $cvxsub = $cv->XSUB; + if (!$$root && !$cvxsub) { + if (try_autoload($cvstashname, $cvname)) { + # Recalculate root and xsub + $root = $cv->ROOT; + $cvxsub = $cv->XSUB; + if ($$root || $cvxsub) { + warn "Successful forced autoload\n"; + } + } + } + my $startfield = 0; + my $padlist = $cv->PADLIST; + my $pv = $cv->PV; + my $xsub = 0; + my $xsubany = "Nullany"; + if ($$root) { + warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n", + $$cv, $$root) if $debug_cv; + my $ppname = ""; + if ($$gv) { + my $stashname = $gv->STASH->NAME; + my $gvname = $gv->NAME; + if ($gvname ne "__ANON__") { + $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_"; + $ppname .= ($stashname eq "main") ? + $gvname : "$stashname\::$gvname"; + $ppname =~ s/::/__/g; + } + } + if (!$ppname) { + $ppname = "pp_anonsub_$anonsub_index"; + $anonsub_index++; + } + $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY); + warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n", + $$cv, $ppname, $$root) if $debug_cv; + if ($$padlist) { + warn sprintf("saving PADLIST 0x%x for CV 0x%x\n", + $$padlist, $$cv) if $debug_cv; + $padlist->save; + warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n", + $$padlist, $$cv) if $debug_cv; + } + } + elsif ($cvxsub) { + $xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY); + # Try to find out canonical name of XSUB function from EGV. + # XXX Doesn't work for XSUBs with PREFIX set (or anyone who + # calls newXS() manually with weird arguments). + my $egv = $gv->EGV; + my $stashname = $egv->STASH->NAME; + $stashname =~ s/::/__/g; + $xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME); + $decl->add("void $xsub _((CV*));"); + } + else { + warn sprintf("No definition for sub %s::%s (unable to autoload)\n", + $cvstashname, $cvname); # debug + } + $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, Nullgv, %d, s\\_%x, (CV*)s\\_%x, 0", + $xpvcv_ix, cstring($pv), length($pv), $cv->IVX, + $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH, + $$padlist, ${$cv->OUTSIDE})); + if ($$gv) { + $gv->save; + $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv)); + warn sprintf("done saving GV 0x%x for CV 0x%x\n", + $$gv, $$cv) if $debug_cv; + } + my $filegv = $cv->FILEGV; + if ($$filegv) { + $filegv->save; + $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv)); + warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n", + $$filegv, $$cv) if $debug_cv; + } + my $stash = $cv->STASH; + if ($$stash) { + $stash->save; + $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash)); + warn sprintf("done saving STASH 0x%x for CV 0x%x\n", + $$stash, $$cv) if $debug_cv; + } + $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x", + $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS)); + return $sym; +} + +sub B::GV::save { + my ($gv) = @_; + my $sym = objsym($gv); + if (defined($sym)) { + #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug + return $sym; + } else { + my $ix = $gv_index++; + $sym = savesym($gv, "gv_list[$ix]"); + #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug + } + my $gvname = $gv->NAME; + my $name = cstring($gv->STASH->NAME . "::" . $gvname); + #warn "GV name is $name\n"; # debug + my $egv = $gv->EGV; + my $egvsym; + if ($$gv != $$egv) { + #warn(sprintf("EGV name is %s, saving it now\n", + # $egv->STASH->NAME . "::" . $egv->NAME)); # debug + $egvsym = $egv->save; + } + $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);], + sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS), + sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS), + sprintf("GvLINE($sym) = %u;", $gv->LINE)); + # Shouldn't need to do save_magic since gv_fetchpv handles that + #$gv->save_magic; + my $refcnt = $gv->REFCNT + 1; + $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1; + my $gvrefcnt = $gv->GvREFCNT; + if ($gvrefcnt > 1) { + $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1)); + } + if (defined($egvsym)) { + # Shared glob *foo = *bar + $init->add("gp_free($sym);", + "GvGP($sym) = GvGP($egvsym);"); + } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) { + # Don't save subfields of special GVs (*_, *1, *# and so on) +# warn "GV::save saving subfields\n"; # debug + my $gvsv = $gv->SV; + if ($$gvsv) { + $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv)); +# warn "GV::save \$$name\n"; # debug + $gvsv->save; + } + my $gvav = $gv->AV; + if ($$gvav) { + $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav)); +# warn "GV::save \@$name\n"; # debug + $gvav->save; + } + my $gvhv = $gv->HV; + if ($$gvhv) { + $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv)); +# warn "GV::save \%$name\n"; # debug + $gvhv->save; + } + my $gvcv = $gv->CV; + if ($$gvcv) { + $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv)); +# warn "GV::save &$name\n"; # debug + $gvcv->save; + } + my $gvfilegv = $gv->FILEGV; + if ($$gvfilegv) { + $init->add(sprintf("GvFILEGV($sym) = s\\_%x;",$$gvfilegv)); +# warn "GV::save GvFILEGV(*$name)\n"; # debug + $gvfilegv->save; + } + my $gvform = $gv->FORM; + if ($$gvform) { + $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform)); +# warn "GV::save GvFORM(*$name)\n"; # debug + $gvform->save; + } + my $gvio = $gv->IO; + if ($$gvio) { + $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio)); +# warn "GV::save GvIO(*$name)\n"; # debug + $gvio->save; + } + } + return $sym; +} +sub B::AV::save { + my ($av) = @_; + my $sym = objsym($av); + return $sym if defined $sym; + my $avflags = $av->AvFLAGS; + $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x", + $avflags)); + $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x", + $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS)); + my $sv_list_index = $svsect->index; + my $fill = $av->FILL; + $av->save_magic; + warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags) + if $debug_av; + # XXX AVf_REAL is wrong test: need to save comppadlist but not stack + #if ($fill > -1 && ($avflags & AVf_REAL)) { + if ($fill > -1) { + my @array = $av->ARRAY; + if ($debug_av) { + my $el; + my $i = 0; + foreach $el (@array) { + warn sprintf("AV 0x%x[%d] = %s 0x%x\n", + $$av, $i++, class($el), $$el); + } + } + my @names = map($_->save, @array); + # XXX Better ways to write loop? + # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...; + # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...; + $init->add("{", + "\tSV **svp;", + "\tAV *av = (AV*)&sv_list[$sv_list_index];", + "\tav_extend(av, $fill);", + "\tsvp = AvARRAY(av);", + map("\t*svp++ = (SV*)$_;", @names), + "\tAvFILLp(av) = $fill;", + "}"); + } else { + my $max = $av->MAX; + $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);") + if $max > -1; + } + return savesym($av, "(AV*)&sv_list[$sv_list_index]"); +} + +sub B::HV::save { + my ($hv) = @_; + my $sym = objsym($hv); + return $sym if defined $sym; + my $name = $hv->NAME; + if ($name) { + # It's a stash + + # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually + # the only symptom is that sv_reset tries to reset the PMf_USED flag of + # a trashed op but we look at the trashed op_type and segfault. + #my $adpmroot = ${$hv->PMROOT}; + my $adpmroot = 0; + $decl->add("static HV *hv$hv_index;"); + # XXX Beware of weird package names containing double-quotes, \n, ...? + $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]); + if ($adpmroot) { + $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;", + $adpmroot)); + } + $sym = savesym($hv, "hv$hv_index"); + $hv_index++; + return $sym; + } + # It's just an ordinary HV + $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0", + $hv->MAX, $hv->RITER)); + $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x", + $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS)); + my $sv_list_index = $svsect->index; + my @contents = $hv->ARRAY; + if (@contents) { + my $i; + for ($i = 1; $i < @contents; $i += 2) { + $contents[$i] = $contents[$i]->save; + } + $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];"); + while (@contents) { + my ($key, $value) = splice(@contents, 0, 2); + $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);", + cstring($key),length($key),$value, hash($key))); + } + $init->add("}"); + } + return savesym($hv, "(HV*)&sv_list[$sv_list_index]"); +} + +sub B::IO::save { + my ($io) = @_; + my $sym = objsym($io); + return $sym if defined $sym; + my $pv = $io->PV; + my $len = length($pv); + $xpviosect->add(sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x", + $len, $len+1, $io->IVX, $io->NVX, $io->LINES, + $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT, + cstring($io->TOP_NAME), cstring($io->FMT_NAME), + cstring($io->BOTTOM_NAME), $io->SUBPROCESS, + cchar($io->IoTYPE), $io->IoFLAGS)); + $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x", + $xpviosect->index, $io->REFCNT + 1, $io->FLAGS)); + $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index)); + my ($field, $fsym); + foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) { + $fsym = $io->$field(); + if ($$fsym) { + $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym)); + $fsym->save; + } + } + $io->save_magic; + return $sym; +} + +sub B::SV::save { + my $sv = shift; + # This is where we catch an honest-to-goodness Nullsv (which gets + # blessed into B::SV explicitly) and any stray erroneous SVs. + return 0 unless $$sv; + confess sprintf("cannot save that type of SV: %s (0x%x)\n", + class($sv), $$sv); +} + +sub output_all { + my $init_name = shift; + my $section; + my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect, + $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect, + $cvopsect, $loopsect, $copsect, $svsect, $xpvsect, + $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, + $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect); + $symsect->output(\*STDOUT, "#define %s\n"); + print "\n"; + output_declarations(); + foreach $section (@sections) { + my $lines = $section->index + 1; + if ($lines) { + my $name = $section->name; + my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name); + print "Static $typename ${name}_list[$lines];\n"; + } + } + $decl->output(\*STDOUT, "%s\n"); + print "\n"; + foreach $section (@sections) { + my $lines = $section->index + 1; + if ($lines) { + my $name = $section->name; + my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name); + printf "static %s %s_list[%u] = {\n", $typename, $name, $lines; + $section->output(\*STDOUT, "\t{ %s },\n"); + print "};\n\n"; + } + } + + print <<"EOT"; +static int $init_name() +{ + dTHR; +EOT + $init->output(\*STDOUT, "\t%s\n"); + print "\treturn 0;\n}\n"; + if ($verbose) { + warn compile_stats(); + warn "NULLOP count: $nullop_count\n"; + } +} + +sub output_declarations { + print <<'EOT'; +#ifdef BROKEN_STATIC_REDECL +#define Static extern +#else +#define Static static +#endif /* BROKEN_STATIC_REDECL */ + +#ifdef BROKEN_UNION_INIT +/* + * Cribbed from cv.h with ANY (a union) replaced by void*. + * Some pre-Standard compilers can't cope with initialising unions. Ho hum. + */ +typedef struct { + char * xpv_pv; /* pointer to malloced string */ + STRLEN xpv_cur; /* length of xp_pv as a C string */ + STRLEN xpv_len; /* allocated size */ + IV xof_off; /* integer value */ + double xnv_nv; /* numeric value, if any */ + MAGIC* xmg_magic; /* magic for scalar array */ + HV* xmg_stash; /* class package */ + + HV * xcv_stash; + OP * xcv_start; + OP * xcv_root; + void (*xcv_xsub) _((CV*)); + void * xcv_xsubany; + GV * xcv_gv; + GV * xcv_filegv; + long xcv_depth; /* >= 2 indicates recursive call */ + AV * xcv_padlist; + CV * xcv_outside; +#ifdef USE_THREADS + perl_mutex *xcv_mutexp; + struct perl_thread *xcv_owner; /* current owner thread */ +#endif /* USE_THREADS */ + U8 xcv_flags; +} XPVCV_or_similar; +#define ANYINIT(i) i +#else +#define XPVCV_or_similar XPVCV +#define ANYINIT(i) {i} +#endif /* BROKEN_UNION_INIT */ +#define Nullany ANYINIT(0) + +#define UNUSED 0 +#define sym_0 0 + +EOT + print "static GV *gv_list[$gv_index];\n" if $gv_index; + print "\n"; +} + + +sub output_boilerplate { + print <<'EOT'; +#include "EXTERN.h" +#include "perl.h" +#ifndef PATCHLEVEL +#include "patchlevel.h" +#endif + +/* Workaround for mapstart: the only op which needs a different ppaddr */ +#undef pp_mapstart +#define pp_mapstart pp_grepstart + +static void xs_init _((void)); +static PerlInterpreter *my_perl; +EOT +} + +sub output_main { + print <<'EOT'; +int +#ifndef CAN_PROTOTYPE +main(argc, argv, env) +int argc; +char **argv; +char **env; +#else /* def(CAN_PROTOTYPE) */ +main(int argc, char **argv, char **env) +#endif /* def(CAN_PROTOTYPE) */ +{ + int exitstatus; + int i; + char **fakeargv; + + PERL_SYS_INIT(&argc,&argv); + + perl_init_i18nl10n(1); + + if (!PL_do_undump) { + my_perl = perl_alloc(); + if (!my_perl) + exit(1); + perl_construct( my_perl ); + } + +#ifdef CSH + if (!PL_cshlen) + PL_cshlen = strlen(PL_cshname); +#endif + +#ifdef ALLOW_PERL_OPTIONS +#define EXTRA_OPTIONS 2 +#else +#define EXTRA_OPTIONS 3 +#endif /* ALLOW_PERL_OPTIONS */ + New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *); + fakeargv[0] = argv[0]; + fakeargv[1] = "-e"; + fakeargv[2] = ""; +#ifndef ALLOW_PERL_OPTIONS + fakeargv[3] = "--"; +#endif /* ALLOW_PERL_OPTIONS */ + for (i = 1; i < argc; i++) + fakeargv[i + EXTRA_OPTIONS] = argv[i]; + fakeargv[argc + EXTRA_OPTIONS] = 0; + + exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS, + fakeargv, NULL); + if (exitstatus) + exit( exitstatus ); + + sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]); + PL_main_cv = PL_compcv; + PL_compcv = 0; + + exitstatus = perl_init(); + if (exitstatus) + exit( exitstatus ); + + exitstatus = perl_run( my_perl ); + + perl_destruct( my_perl ); + perl_free( my_perl ); + + exit( exitstatus ); +} + +static void +xs_init() +{ +} +EOT +} + +sub dump_symtable { + # For debugging + my ($sym, $val); + warn "----Symbol table:\n"; + while (($sym, $val) = each %symtable) { + warn "$sym => $val\n"; + } + warn "---End of symbol table\n"; +} + +sub save_object { + my $sv; + foreach $sv (@_) { + svref_2object($sv)->save; + } +} + +sub B::GV::savecv { + my $gv = shift; + my $cv = $gv->CV; + my $name = $gv->NAME; + if ($$cv && !objsym($cv) && !($name eq "bootstrap" && $cv->XSUB)) { + if ($debug_cv) { + warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", + $gv->STASH->NAME, $name, $$cv, $$gv); + } + $gv->save; + } +} + +sub save_unused_subs { + my %search_pack; + map { $search_pack{$_} = 1 } @_; + no strict qw(vars refs); + walksymtable(\%{"main::"}, "savecv", sub { + my $package = shift; + $package =~ s/::$//; + #warn "Considering $package\n";#debug + return 1 if exists $search_pack{$package}; + #warn " (nothing explicit)\n";#debug + # Omit the packages which we use (and which cause grief + # because of fancy "goto &$AUTOLOAD" stuff). + # XXX Surely there must be a nicer way to do this. + if ($package eq "FileHandle" + || $package eq "Config" + || $package eq "SelectSaver") { + return 0; + } + my $m; + foreach $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) { + if (defined(&{$package."::$m"})) { + warn "$package has method $m: -u$package assumed\n";#debug + return 1; + } + } + return 0; + }); +} + +sub save_main { + my $curpad_sym = (comppadlist->ARRAY)[1]->save; + walkoptree(main_root, "save"); + warn "done main optree, walking symtable for extras\n" if $debug_cv; + save_unused_subs(@unused_sub_packages); + + $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), + sprintf("PL_main_start = s\\_%x;", ${main_start()}), + "PL_curpad = AvARRAY($curpad_sym);"); + output_boilerplate(); + print "\n"; + output_all("perl_init"); + print "\n"; + output_main(); +} + +sub init_sections { + my @sections = (init => \$init, decl => \$decl, sym => \$symsect, + binop => \$binopsect, condop => \$condopsect, + cop => \$copsect, cvop => \$cvopsect, gvop => \$gvopsect, + listop => \$listopsect, logop => \$logopsect, + loop => \$loopsect, op => \$opsect, pmop => \$pmopsect, + pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect, + sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect, + xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect, + xpviv => \$xpvivsect, xpvnv => \$xpvnvsect, + xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect, + xrv => \$xrvsect, xpvbm => \$xpvbmsect, + xpvio => \$xpviosect); + my ($name, $sectref); + while (($name, $sectref) = splice(@sections, 0, 2)) { + $$sectref = new B::Section $name, \%symtable, 0; + } +} + +sub compile { + my @options = @_; + my ($option, $opt, $arg); + OPTION: + while ($option = shift @options) { + if ($option =~ /^-(.)(.*)/) { + $opt = $1; + $arg = $2; + } else { + unshift @options, $option; + last OPTION; + } + if ($opt eq "-" && $arg eq "-") { + shift @options; + last OPTION; + } + if ($opt eq "w") { + $warn_undefined_syms = 1; + } elsif ($opt eq "D") { + $arg ||= shift @options; + foreach $arg (split(//, $arg)) { + if ($arg eq "o") { + B->debug(1); + } elsif ($arg eq "c") { + $debug_cops = 1; + } elsif ($arg eq "A") { + $debug_av = 1; + } elsif ($arg eq "C") { + $debug_cv = 1; + } elsif ($arg eq "M") { + $debug_mg = 1; + } else { + warn "ignoring unknown debug option: $arg\n"; + } + } + } elsif ($opt eq "o") { + $arg ||= shift @options; + open(STDOUT, ">$arg") or return "$arg: $!\n"; + } elsif ($opt eq "v") { + $verbose = 1; + } elsif ($opt eq "u") { + $arg ||= shift @options; + push(@unused_sub_packages, $arg); + } elsif ($opt eq "f") { + $arg ||= shift @options; + if ($arg eq "cog") { + $pv_copy_on_grow = 1; + } elsif ($arg eq "no-cog") { + $pv_copy_on_grow = 0; + } + } elsif ($opt eq "O") { + $arg = 1 if $arg eq ""; + $pv_copy_on_grow = 0; + if ($arg >= 1) { + # Optimisations for -O1 + $pv_copy_on_grow = 1; + } + } + } + init_sections(); + if (@options) { + return sub { + my $objname; + foreach $objname (@options) { + eval "save_object(\\$objname)"; + } + output_all(); + } + } else { + return sub { save_main() }; + } +} + +1; + +__END__ + +=head1 NAME + +B::C - Perl compiler's C backend + +=head1 SYNOPSIS + + perl -MO=C[,OPTIONS] foo.pl + +=head1 DESCRIPTION + +This compiler backend takes Perl source and generates C source code +corresponding to the internal structures that perl uses to run +your program. When the generated C source is compiled and run, it +cuts out the time which perl would have taken to load and parse +your program into its internal semi-compiled form. That means that +compiling with this backend will not help improve the runtime +execution speed of your program but may improve the start-up time. +Depending on the environment in which your program runs this may be +either a help or a hindrance. + +=head1 OPTIONS + +If there are any non-option arguments, they are taken to be +names of objects to be saved (probably doesn't work properly yet). +Without extra arguments, it saves the main program. + +=over 4 + +=item B<-ofilename> + +Output to filename instead of STDOUT + +=item B<-v> + +Verbose compilation (currently gives a few compilation statistics). + +=item B<--> + +Force end of options + +=item B<-uPackname> + +Force apparently unused subs from package Packname to be compiled. +This allows programs to use eval "foo()" even when sub foo is never +seen to be used at compile time. The down side is that any subs which +really are never used also have code generated. This option is +necessary, for example, if you have a signal handler foo which you +initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just +to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u> +options. The compiler tries to figure out which packages may possibly +have subs in which need compiling but the current version doesn't do +it very well. In particular, it is confused by nested packages (i.e. +of the form C) where package C does not contain any subs. + +=item B<-D> + +Debug options (concatenated or separate flags like C). + +=item B<-Do> + +OPs, prints each OP as it's processed + +=item B<-Dc> + +COPs, prints COPs as processed (incl. file & line num) + +=item B<-DA> + +prints AV information on saving + +=item B<-DC> + +prints CV information on saving + +=item B<-DM> + +prints MAGIC information on saving + +=item B<-f> + +Force optimisations on or off one at a time. + +=item B<-fcog> + +Copy-on-grow: PVs declared and initialised statically. + +=item B<-fno-cog> + +No copy-on-grow. + +=item B<-On> + +Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently, +B<-O1> and higher set B<-fcog>. + +=head1 EXAMPLES + + perl -MO=C,-ofoo.c foo.pl + perl cc_harness -o foo foo.c + +Note that C lives in the C subdirectory of your perl +library directory. The utility called C may also be used to +help make use of this compiler. + + perl -MO=C,-v,-DcA bar.pl > /dev/null + +=head1 BUGS + +Plenty. Current status: experimental. + +=head1 AUTHOR + +Malcolm Beattie, C + +=cut diff --git a/contrib/perl5/ext/B/B/CC.pm b/contrib/perl5/ext/B/B/CC.pm new file mode 100644 index 0000000..9991d8e --- /dev/null +++ b/contrib/perl5/ext/B/B/CC.pm @@ -0,0 +1,1734 @@ +# CC.pm +# +# Copyright (c) 1996, 1997, 1998 Malcolm Beattie +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the README file. +# +package B::CC; +use strict; +use B qw(main_start main_root class comppadlist peekop svref_2object + timing_info); +use B::C qw(save_unused_subs objsym init_sections + output_all output_boilerplate output_main); +use B::Bblock qw(find_leaders); +use B::Stackobj qw(:types :flags); + +# These should probably be elsewhere +# Flags for $op->flags +sub OPf_LIST () { 1 } +sub OPf_KNOW () { 2 } +sub OPf_MOD () { 32 } +sub OPf_STACKED () { 64 } +sub OPf_SPECIAL () { 128 } +# op-specific flags for $op->private +sub OPpASSIGN_BACKWARDS () { 64 } +sub OPpLVAL_INTRO () { 128 } +sub OPpDEREF_AV () { 32 } +sub OPpDEREF_HV () { 64 } +sub OPpDEREF () { OPpDEREF_AV|OPpDEREF_HV } +sub OPpFLIP_LINENUM () { 64 } +sub G_ARRAY () { 1 } +# cop.h +sub CXt_NULL () { 0 } +sub CXt_SUB () { 1 } +sub CXt_EVAL () { 2 } +sub CXt_LOOP () { 3 } +sub CXt_SUBST () { 4 } +sub CXt_BLOCK () { 5 } + +my $module; # module name (when compiled with -m) +my %done; # hash keyed by $$op of leaders of basic blocks + # which have already been done. +my $leaders; # ref to hash of basic block leaders. Keys are $$op + # addresses, values are the $op objects themselves. +my @bblock_todo; # list of leaders of basic blocks that need visiting + # sometime. +my @cc_todo; # list of tuples defining what PP code needs to be + # saved (e.g. CV, main or PMOP repl code). Each tuple + # is [$name, $root, $start, @padlist]. PMOP repl code + # tuples inherit padlist. +my @stack; # shadows perl's stack when contents are known. + # Values are objects derived from class B::Stackobj +my @pad; # Lexicals in current pad as Stackobj-derived objects +my @padlist; # Copy of current padlist so PMOP repl code can find it +my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo +my $jmpbuf_ix = 0; # Next free index for dynamically allocated jmpbufs +my %constobj; # OP_CONST constants as Stackobj-derived objects + # keyed by $$sv. +my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic + # block or even to the end of each loop of blocks, + # depending on optimisation options. +my $know_op = 0; # Set when C variable op already holds the right op + # (from an immediately preceding DOOP(ppname)). +my $errors = 0; # Number of errors encountered +my %skip_stack; # Hash of PP names which don't need write_back_stack +my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals +my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals +my %ignore_op; # Hash of ops which do nothing except returning op_next + +BEGIN { + foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) { + $ignore_op{$_} = 1; + } +} + +my @unused_sub_packages; # list of packages (given by -u options) to search + # explicitly and save every sub we find there, even + # if apparently unused (could be only referenced from + # an eval "" or from a $SIG{FOO} = "bar"). + +my ($module_name); +my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime, + $debug_shadow, $debug_queue, $debug_lineno, $debug_timings); + +# Optimisation options. On the command line, use hyphens instead of +# underscores for compatibility with gcc-style options. We use +# underscores here because they are OK in (strict) barewords. +my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint); +my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock, + freetmps_each_loop => \$freetmps_each_loop, + omit_taint => \$omit_taint); +# perl patchlevel to generate code for (defaults to current patchlevel) +my $patchlevel = int(0.5 + 1000 * ($] - 5)); + +# Could rewrite push_runtime() and output_runtime() to use a +# temporary file if memory is at a premium. +my $ppname; # name of current fake PP function +my $runtime_list_ref; +my $declare_ref; # Hash ref keyed by C variable type of declarations. + +my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref] + # tuples to be written out. + +my ($init, $decl); + +sub init_hash { map { $_ => 1 } @_ } + +# +# Initialise the hashes for the default PP functions where we can avoid +# either write_back_stack, write_back_lexicals or invalidate_lexicals. +# +%skip_lexicals = init_hash qw(pp_enter pp_enterloop); +%skip_invalidate = init_hash qw(pp_enter pp_enterloop); + +sub debug { + if ($debug_runtime) { + warn(@_); + } else { + runtime(map { chomp; "/* $_ */"} @_); + } +} + +sub declare { + my ($type, $var) = @_; + push(@{$declare_ref->{$type}}, $var); +} + +sub push_runtime { + push(@$runtime_list_ref, @_); + warn join("\n", @_) . "\n" if $debug_runtime; +} + +sub save_runtime { + push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]); +} + +sub output_runtime { + my $ppdata; + print qq(#include "cc_runtime.h"\n); + foreach $ppdata (@pp_list) { + my ($name, $runtime, $declare) = @$ppdata; + print "\nstatic\nPP($name)\n{\n"; + my ($type, $varlist, $line); + while (($type, $varlist) = each %$declare) { + print "\t$type ", join(", ", @$varlist), ";\n"; + } + foreach $line (@$runtime) { + print $line, "\n"; + } + print "}\n"; + } +} + +sub runtime { + my $line; + foreach $line (@_) { + push_runtime("\t$line"); + } +} + +sub init_pp { + $ppname = shift; + $runtime_list_ref = []; + $declare_ref = {}; + runtime("djSP;"); + declare("I32", "oldsave"); + declare("SV", "**svp"); + map { declare("SV", "*$_") } qw(sv src dst left right); + declare("MAGIC", "*mg"); + $decl->add("static OP * $ppname _((ARGSproto));"); + debug "init_pp: $ppname\n" if $debug_queue; +} + +# Initialise runtime_callback function for Stackobj class +BEGIN { B::Stackobj::set_callback(\&runtime) } + +# Initialise saveoptree_callback for B::C class +sub cc_queue { + my ($name, $root, $start, @pl) = @_; + debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n" + if $debug_queue; + if ($name eq "*ignore*") { + $name = 0; + } else { + push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]); + } + my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name); + $start = $fakeop->save; + debug "cc_queue: name $name returns $start\n" if $debug_queue; + return $start; +} +BEGIN { B::C::set_callback(\&cc_queue) } + +sub valid_int { $_[0]->{flags} & VALID_INT } +sub valid_double { $_[0]->{flags} & VALID_DOUBLE } +sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) } +sub valid_sv { $_[0]->{flags} & VALID_SV } + +sub top_int { @stack ? $stack[-1]->as_int : "TOPi" } +sub top_double { @stack ? $stack[-1]->as_double : "TOPn" } +sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" } +sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" } +sub top_bool { @stack ? $stack[-1]->as_numeric : "SvTRUE(TOPs)" } + +sub pop_int { @stack ? (pop @stack)->as_int : "POPi" } +sub pop_double { @stack ? (pop @stack)->as_double : "POPn" } +sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" } +sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" } +sub pop_bool { + if (@stack) { + return ((pop @stack)->as_numeric); + } else { + # Careful: POPs has an auto-decrement and SvTRUE evaluates + # its argument more than once. + runtime("sv = POPs;"); + return "SvTRUE(sv)"; + } +} + +sub write_back_lexicals { + my $avoid = shift || 0; + debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n" + if $debug_shadow; + my $lex; + foreach $lex (@pad) { + next unless ref($lex); + $lex->write_back unless $lex->{flags} & $avoid; + } +} + +sub write_back_stack { + my $obj; + return unless @stack; + runtime(sprintf("EXTEND(sp, %d);", scalar(@stack))); + foreach $obj (@stack) { + runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv)); + } + @stack = (); +} + +sub invalidate_lexicals { + my $avoid = shift || 0; + debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n" + if $debug_shadow; + my $lex; + foreach $lex (@pad) { + next unless ref($lex); + $lex->invalidate unless $lex->{flags} & $avoid; + } +} + +sub reload_lexicals { + my $lex; + foreach $lex (@pad) { + next unless ref($lex); + my $type = $lex->{type}; + if ($type == T_INT) { + $lex->as_int; + } elsif ($type == T_DOUBLE) { + $lex->as_double; + } else { + $lex->as_sv; + } + } +} + +{ + package B::Pseudoreg; + # + # This class allocates pseudo-registers (OK, so they're C variables). + # + my %alloc; # Keyed by variable name. A value of 1 means the + # variable has been declared. A value of 2 means + # it's in use. + + sub new_scope { %alloc = () } + + sub new ($$$) { + my ($class, $type, $prefix) = @_; + my ($ptr, $i, $varname, $status, $obj); + $prefix =~ s/^(\**)//; + $ptr = $1; + $i = 0; + do { + $varname = "$prefix$i"; + $status = $alloc{$varname}; + } while $status == 2; + if ($status != 1) { + # Not declared yet + B::CC::declare($type, "$ptr$varname"); + $alloc{$varname} = 2; # declared and in use + } + $obj = bless \$varname, $class; + return $obj; + } + sub DESTROY { + my $obj = shift; + $alloc{$$obj} = 1; # no longer in use but still declared + } +} +{ + package B::Shadow; + # + # This class gives a standard API for a perl object to shadow a + # C variable and only generate reloads/write-backs when necessary. + # + # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo"). + # Use $obj->write_back whenever shadowed_c_var needs to be up to date. + # Use $obj->invalidate whenever an unknown function may have + # set shadow itself. + + sub new { + my ($class, $write_back) = @_; + # Object fields are perl shadow variable, validity flag + # (for *C* variable) and callback sub for write_back + # (passed perl shadow variable as argument). + bless [undef, 1, $write_back], $class; + } + sub load { + my ($obj, $newval) = @_; + $obj->[1] = 0; # C variable no longer valid + $obj->[0] = $newval; + } + sub write_back { + my $obj = shift; + if (!($obj->[1])) { + $obj->[1] = 1; # C variable will now be valid + &{$obj->[2]}($obj->[0]); + } + } + sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid +} +my $curcop = new B::Shadow (sub { + my $opsym = shift->save; + runtime("PL_curcop = (COP*)$opsym;"); +}); + +# +# Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on. +# +sub dopoptoloop { + my $cxix = $#cxstack; + while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) { + $cxix--; + } + debug "dopoptoloop: returning $cxix" if $debug_cxstack; + return $cxix; +} + +sub dopoptolabel { + my $label = shift; + my $cxix = $#cxstack; + while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP + && $cxstack[$cxix]->{label} ne $label) { + $cxix--; + } + debug "dopoptolabel: returning $cxix" if $debug_cxstack; + return $cxix; +} + +sub error { + my $format = shift; + my $file = $curcop->[0]->filegv->SV->PV; + my $line = $curcop->[0]->line; + $errors++; + if (@_) { + warn sprintf("%s:%d: $format\n", $file, $line, @_); + } else { + warn sprintf("%s:%d: %s\n", $file, $line, $format); + } +} + +# +# Load pad takes (the elements of) a PADLIST as arguments and loads +# up @pad with Stackobj-derived objects which represent those lexicals. +# If/when perl itself can generate type information (my int $foo) then +# we'll take advantage of that here. Until then, we'll use various hacks +# to tell the compiler when we want a lexical to be a particular type +# or to be a register. +# +sub load_pad { + my ($namelistav, $valuelistav) = @_; + @padlist = @_; + my @namelist = $namelistav->ARRAY; + my @valuelist = $valuelistav->ARRAY; + my $ix; + @pad = (); + debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad; + # Temporary lexicals don't get named so it's possible for @valuelist + # to be strictly longer than @namelist. We count $ix up to the end of + # @valuelist but index into @namelist for the name. Any temporaries which + # run off the end of @namelist will make $namesv undefined and we treat + # that the same as having an explicit SPECIAL sv_undef object in @namelist. + # [XXX If/when @_ becomes a lexical, we must start at 0 here.] + for ($ix = 1; $ix < @valuelist; $ix++) { + my $namesv = $namelist[$ix]; + my $type = T_UNKNOWN; + my $flags = 0; + my $name = "tmp$ix"; + my $class = class($namesv); + if (!defined($namesv) || $class eq "SPECIAL") { + # temporaries have &PL_sv_undef instead of a PVNV for a name + $flags = VALID_SV|TEMPORARY|REGISTER; + } else { + if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) { + $name = $1; + if ($2 eq "i") { + $type = T_INT; + $flags = VALID_SV|VALID_INT; + } elsif ($2 eq "d") { + $type = T_DOUBLE; + $flags = VALID_SV|VALID_DOUBLE; + } + $flags |= REGISTER if $3; + } + } + $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix, + "i_$name", "d_$name"); + declare("IV", $type == T_INT ? "i_$name = 0" : "i_$name"); + declare("double", $type == T_DOUBLE ? "d_$name = 0" : "d_$name"); + debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad; + } +} + +# +# Debugging stuff +# +sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) } + +# +# OP stuff +# + +sub label { + my $op = shift; + # XXX Preserve original label name for "real" labels? + return sprintf("lab_%x", $$op); +} + +sub write_label { + my $op = shift; + push_runtime(sprintf(" %s:", label($op))); +} + +sub loadop { + my $op = shift; + my $opsym = $op->save; + runtime("PL_op = $opsym;") unless $know_op; + return $opsym; +} + +sub doop { + my $op = shift; + my $ppname = $op->ppaddr; + my $sym = loadop($op); + runtime("DOOP($ppname);"); + $know_op = 1; + return $sym; +} + +sub gimme { + my $op = shift; + my $flags = $op->flags; + return (($flags & OPf_KNOW) ? ($flags & OPf_LIST) : "dowantarray()"); +} + +# +# Code generation for PP code +# + +sub pp_null { + my $op = shift; + return $op->next; +} + +sub pp_stub { + my $op = shift; + my $gimme = gimme($op); + if ($gimme != 1) { + # XXX Change to push a constant sv_undef Stackobj onto @stack + write_back_stack(); + runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);"); + } + return $op->next; +} + +sub pp_unstack { + my $op = shift; + @stack = (); + runtime("PP_UNSTACK;"); + return $op->next; +} + +sub pp_and { + my $op = shift; + my $next = $op->next; + reload_lexicals(); + unshift(@bblock_todo, $next); + if (@stack >= 1) { + my $bool = pop_bool(); + write_back_stack(); + runtime(sprintf("if (!$bool) goto %s;", label($next))); + } else { + runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)), + "*sp--;"); + } + return $op->other; +} + +sub pp_or { + my $op = shift; + my $next = $op->next; + reload_lexicals(); + unshift(@bblock_todo, $next); + if (@stack >= 1) { + my $obj = pop @stack; + write_back_stack(); + runtime(sprintf("if (%s) { XPUSHs(%s); goto %s; }", + $obj->as_numeric, $obj->as_sv, label($next))); + } else { + runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)), + "*sp--;"); + } + return $op->other; +} + +sub pp_cond_expr { + my $op = shift; + my $false = $op->false; + unshift(@bblock_todo, $false); + reload_lexicals(); + my $bool = pop_bool(); + write_back_stack(); + runtime(sprintf("if (!$bool) goto %s;", label($false))); + return $op->true; +} + +sub pp_padsv { + my $op = shift; + my $ix = $op->targ; + push(@stack, $pad[$ix]); + if ($op->flags & OPf_MOD) { + my $private = $op->private; + if ($private & OPpLVAL_INTRO) { + runtime("SAVECLEARSV(PL_curpad[$ix]);"); + } elsif ($private & OPpDEREF) { + runtime(sprintf("vivify_ref(PL_curpad[%d], %d);", + $ix, $private & OPpDEREF)); + $pad[$ix]->invalidate; + } + } + return $op->next; +} + +sub pp_const { + my $op = shift; + my $sv = $op->sv; + my $obj = $constobj{$$sv}; + if (!defined($obj)) { + $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv); + } + push(@stack, $obj); + return $op->next; +} + +sub pp_nextstate { + my $op = shift; + $curcop->load($op); + @stack = (); + debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno; + runtime("TAINT_NOT;") unless $omit_taint; + runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;"); + if ($freetmps_each_bblock || $freetmps_each_loop) { + $need_freetmps = 1; + } else { + runtime("FREETMPS;"); + } + return $op->next; +} + +sub pp_dbstate { + my $op = shift; + $curcop->invalidate; # XXX? + return default_pp($op); +} + +sub pp_rv2gv { $curcop->write_back; default_pp(@_) } +sub pp_bless { $curcop->write_back; default_pp(@_) } +sub pp_repeat { $curcop->write_back; default_pp(@_) } +# The following subs need $curcop->write_back if we decide to support arybase: +# pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice +sub pp_sort { $curcop->write_back; default_pp(@_) } +sub pp_caller { $curcop->write_back; default_pp(@_) } +sub pp_reset { $curcop->write_back; default_pp(@_) } + +sub pp_gv { + my $op = shift; + my $gvsym = $op->gv->save; + write_back_stack(); + runtime("XPUSHs((SV*)$gvsym);"); + return $op->next; +} + +sub pp_gvsv { + my $op = shift; + my $gvsym = $op->gv->save; + write_back_stack(); + if ($op->private & OPpLVAL_INTRO) { + runtime("XPUSHs(save_scalar($gvsym));"); + } else { + runtime("XPUSHs(GvSV($gvsym));"); + } + return $op->next; +} + +sub pp_aelemfast { + my $op = shift; + my $gvsym = $op->gv->save; + my $ix = $op->private; + my $flag = $op->flags & OPf_MOD; + write_back_stack(); + runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);", + "PUSHs(svp ? *svp : &PL_sv_undef);"); + return $op->next; +} + +sub int_binop { + my ($op, $operator) = @_; + if ($op->flags & OPf_STACKED) { + my $right = pop_int(); + if (@stack >= 1) { + my $left = top_int(); + $stack[-1]->set_int(&$operator($left, $right)); + } else { + runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right))); + } + } else { + my $targ = $pad[$op->targ]; + my $right = new B::Pseudoreg ("IV", "riv"); + my $left = new B::Pseudoreg ("IV", "liv"); + runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int)); + $targ->set_int(&$operator($$left, $$right)); + push(@stack, $targ); + } + return $op->next; +} + +sub INTS_CLOSED () { 0x1 } +sub INT_RESULT () { 0x2 } +sub NUMERIC_RESULT () { 0x4 } + +sub numeric_binop { + my ($op, $operator, $flags) = @_; + my $force_int = 0; + $force_int ||= ($flags & INT_RESULT); + $force_int ||= ($flags & INTS_CLOSED && @stack >= 2 + && valid_int($stack[-2]) && valid_int($stack[-1])); + if ($op->flags & OPf_STACKED) { + my $right = pop_numeric(); + if (@stack >= 1) { + my $left = top_numeric(); + if ($force_int) { + $stack[-1]->set_int(&$operator($left, $right)); + } else { + $stack[-1]->set_numeric(&$operator($left, $right)); + } + } else { + if ($force_int) { + runtime(sprintf("sv_setiv(TOPs, %s);", + &$operator("TOPi", $right))); + } else { + runtime(sprintf("sv_setnv(TOPs, %s);", + &$operator("TOPn", $right))); + } + } + } else { + my $targ = $pad[$op->targ]; + $force_int ||= ($targ->{type} == T_INT); + if ($force_int) { + my $right = new B::Pseudoreg ("IV", "riv"); + my $left = new B::Pseudoreg ("IV", "liv"); + runtime(sprintf("$$right = %s; $$left = %s;", + pop_numeric(), pop_numeric)); + $targ->set_int(&$operator($$left, $$right)); + } else { + my $right = new B::Pseudoreg ("double", "rnv"); + my $left = new B::Pseudoreg ("double", "lnv"); + runtime(sprintf("$$right = %s; $$left = %s;", + pop_numeric(), pop_numeric)); + $targ->set_numeric(&$operator($$left, $$right)); + } + push(@stack, $targ); + } + return $op->next; +} + +sub sv_binop { + my ($op, $operator, $flags) = @_; + if ($op->flags & OPf_STACKED) { + my $right = pop_sv(); + if (@stack >= 1) { + my $left = top_sv(); + if ($flags & INT_RESULT) { + $stack[-1]->set_int(&$operator($left, $right)); + } elsif ($flags & NUMERIC_RESULT) { + $stack[-1]->set_numeric(&$operator($left, $right)); + } else { + # XXX Does this work? + runtime(sprintf("sv_setsv($left, %s);", + &$operator($left, $right))); + $stack[-1]->invalidate; + } + } else { + my $f; + if ($flags & INT_RESULT) { + $f = "sv_setiv"; + } elsif ($flags & NUMERIC_RESULT) { + $f = "sv_setnv"; + } else { + $f = "sv_setsv"; + } + runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right))); + } + } else { + my $targ = $pad[$op->targ]; + runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv)); + if ($flags & INT_RESULT) { + $targ->set_int(&$operator("left", "right")); + } elsif ($flags & NUMERIC_RESULT) { + $targ->set_numeric(&$operator("left", "right")); + } else { + # XXX Does this work? + runtime(sprintf("sv_setsv(%s, %s);", + $targ->as_sv, &$operator("left", "right"))); + $targ->invalidate; + } + push(@stack, $targ); + } + return $op->next; +} + +sub bool_int_binop { + my ($op, $operator) = @_; + my $right = new B::Pseudoreg ("IV", "riv"); + my $left = new B::Pseudoreg ("IV", "liv"); + runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int())); + my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b")); + $bool->set_int(&$operator($$left, $$right)); + push(@stack, $bool); + return $op->next; +} + +sub bool_numeric_binop { + my ($op, $operator) = @_; + my $right = new B::Pseudoreg ("double", "rnv"); + my $left = new B::Pseudoreg ("double", "lnv"); + runtime(sprintf("$$right = %s; $$left = %s;", + pop_numeric(), pop_numeric())); + my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b")); + $bool->set_numeric(&$operator($$left, $$right)); + push(@stack, $bool); + return $op->next; +} + +sub bool_sv_binop { + my ($op, $operator) = @_; + runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv())); + my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b")); + $bool->set_numeric(&$operator("left", "right")); + push(@stack, $bool); + return $op->next; +} + +sub infix_op { + my $opname = shift; + return sub { "$_[0] $opname $_[1]" } +} + +sub prefix_op { + my $opname = shift; + return sub { sprintf("%s(%s)", $opname, join(", ", @_)) } +} + +BEGIN { + my $plus_op = infix_op("+"); + my $minus_op = infix_op("-"); + my $multiply_op = infix_op("*"); + my $divide_op = infix_op("/"); + my $modulo_op = infix_op("%"); + my $lshift_op = infix_op("<<"); + my $rshift_op = infix_op(">>"); + my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" }; + my $scmp_op = prefix_op("sv_cmp"); + my $seq_op = prefix_op("sv_eq"); + my $sne_op = prefix_op("!sv_eq"); + my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" }; + my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" }; + my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" }; + my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" }; + my $eq_op = infix_op("=="); + my $ne_op = infix_op("!="); + my $lt_op = infix_op("<"); + my $gt_op = infix_op(">"); + my $le_op = infix_op("<="); + my $ge_op = infix_op(">="); + + # + # XXX The standard perl PP code has extra handling for + # some special case arguments of these operators. + # + sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) } + sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) } + sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) } + sub pp_divide { numeric_binop($_[0], $divide_op) } + sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's + sub pp_ncmp { numeric_binop($_[0], $ncmp_op, INT_RESULT) } + + sub pp_left_shift { int_binop($_[0], $lshift_op) } + sub pp_right_shift { int_binop($_[0], $rshift_op) } + sub pp_i_add { int_binop($_[0], $plus_op) } + sub pp_i_subtract { int_binop($_[0], $minus_op) } + sub pp_i_multiply { int_binop($_[0], $multiply_op) } + sub pp_i_divide { int_binop($_[0], $divide_op) } + sub pp_i_modulo { int_binop($_[0], $modulo_op) } + + sub pp_eq { bool_numeric_binop($_[0], $eq_op) } + sub pp_ne { bool_numeric_binop($_[0], $ne_op) } + sub pp_lt { bool_numeric_binop($_[0], $lt_op) } + sub pp_gt { bool_numeric_binop($_[0], $gt_op) } + sub pp_le { bool_numeric_binop($_[0], $le_op) } + sub pp_ge { bool_numeric_binop($_[0], $ge_op) } + + sub pp_i_eq { bool_int_binop($_[0], $eq_op) } + sub pp_i_ne { bool_int_binop($_[0], $ne_op) } + sub pp_i_lt { bool_int_binop($_[0], $lt_op) } + sub pp_i_gt { bool_int_binop($_[0], $gt_op) } + sub pp_i_le { bool_int_binop($_[0], $le_op) } + sub pp_i_ge { bool_int_binop($_[0], $ge_op) } + + sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) } + sub pp_slt { bool_sv_binop($_[0], $slt_op) } + sub pp_sgt { bool_sv_binop($_[0], $sgt_op) } + sub pp_sle { bool_sv_binop($_[0], $sle_op) } + sub pp_sge { bool_sv_binop($_[0], $sge_op) } + sub pp_seq { bool_sv_binop($_[0], $seq_op) } + sub pp_sne { bool_sv_binop($_[0], $sne_op) } +} + + +sub pp_sassign { + my $op = shift; + my $backwards = $op->private & OPpASSIGN_BACKWARDS; + my ($dst, $src); + if (@stack >= 2) { + $dst = pop @stack; + $src = pop @stack; + ($src, $dst) = ($dst, $src) if $backwards; + my $type = $src->{type}; + if ($type == T_INT) { + $dst->set_int($src->as_int); + } elsif ($type == T_DOUBLE) { + $dst->set_numeric($src->as_numeric); + } else { + $dst->set_sv($src->as_sv); + } + push(@stack, $dst); + } elsif (@stack == 1) { + if ($backwards) { + my $src = pop @stack; + my $type = $src->{type}; + runtime("if (PL_tainting && PL_tainted) TAINT_NOT;"); + if ($type == T_INT) { + runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int); + } elsif ($type == T_DOUBLE) { + runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double); + } else { + runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv); + } + runtime("SvSETMAGIC(TOPs);"); + } else { + my $dst = pop @stack; + my $type = $dst->{type}; + runtime("sv = POPs;"); + runtime("MAYBE_TAINT_SASSIGN_SRC(sv);"); + if ($type == T_INT) { + $dst->set_int("SvIV(sv)"); + } elsif ($type == T_DOUBLE) { + $dst->set_double("SvNV(sv)"); + } else { + runtime("SvSetSV($dst->{sv}, sv);"); + $dst->invalidate; + } + } + } else { + if ($backwards) { + runtime("src = POPs; dst = TOPs;"); + } else { + runtime("dst = POPs; src = TOPs;"); + } + runtime("MAYBE_TAINT_SASSIGN_SRC(src);", + "SvSetSV(dst, src);", + "SvSETMAGIC(dst);", + "SETs(dst);"); + } + return $op->next; +} + +sub pp_preinc { + my $op = shift; + if (@stack >= 1) { + my $obj = $stack[-1]; + my $type = $obj->{type}; + if ($type == T_INT || $type == T_DOUBLE) { + $obj->set_int($obj->as_int . " + 1"); + } else { + runtime sprintf("PP_PREINC(%s);", $obj->as_sv); + $obj->invalidate(); + } + } else { + runtime sprintf("PP_PREINC(TOPs);"); + } + return $op->next; +} + +sub pp_pushmark { + my $op = shift; + write_back_stack(); + runtime("PUSHMARK(sp);"); + return $op->next; +} + +sub pp_list { + my $op = shift; + write_back_stack(); + my $gimme = gimme($op); + if ($gimme == 1) { # sic + runtime("POPMARK;"); # need this even though not a "full" pp_list + } else { + runtime("PP_LIST($gimme);"); + } + return $op->next; +} + +sub pp_entersub { + my $op = shift; + write_back_lexicals(REGISTER|TEMPORARY); + write_back_stack(); + my $sym = doop($op); + runtime("if (PL_op != ($sym)->op_next) PL_op = (*PL_op->op_ppaddr)(ARGS);"); + runtime("SPAGAIN;"); + $know_op = 0; + invalidate_lexicals(REGISTER|TEMPORARY); + return $op->next; +} + +sub pp_enterwrite { + my $op = shift; + pp_entersub($op); +} + +sub pp_leavewrite { + my $op = shift; + write_back_lexicals(REGISTER|TEMPORARY); + write_back_stack(); + my $sym = doop($op); + # XXX Is this the right way to distinguish between it returning + # CvSTART(cv) (via doform) and pop_return()? + runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(ARGS);"); + runtime("SPAGAIN;"); + $know_op = 0; + invalidate_lexicals(REGISTER|TEMPORARY); + return $op->next; +} + +sub doeval { + my $op = shift; + $curcop->write_back; + write_back_lexicals(REGISTER|TEMPORARY); + write_back_stack(); + my $sym = loadop($op); + my $ppaddr = $op->ppaddr; + runtime("PP_EVAL($ppaddr, ($sym)->op_next);"); + $know_op = 1; + invalidate_lexicals(REGISTER|TEMPORARY); + return $op->next; +} + +sub pp_entereval { doeval(@_) } +sub pp_require { doeval(@_) } +sub pp_dofile { doeval(@_) } + +sub pp_entertry { + my $op = shift; + $curcop->write_back; + write_back_lexicals(REGISTER|TEMPORARY); + write_back_stack(); + my $sym = doop($op); + my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++); + declare("Sigjmp_buf", $jmpbuf); + runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next))); + invalidate_lexicals(REGISTER|TEMPORARY); + return $op->next; +} + +sub pp_grepstart { + my $op = shift; + if ($need_freetmps && $freetmps_each_loop) { + runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up + $need_freetmps = 0; + } + write_back_stack(); + doop($op); + return $op->next->other; +} + +sub pp_mapstart { + my $op = shift; + if ($need_freetmps && $freetmps_each_loop) { + runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up + $need_freetmps = 0; + } + write_back_stack(); + doop($op); + return $op->next->other; +} + +sub pp_grepwhile { + my $op = shift; + my $next = $op->next; + unshift(@bblock_todo, $next); + write_back_lexicals(); + write_back_stack(); + my $sym = doop($op); + # pp_grepwhile can return either op_next or op_other and we need to + # be able to distinguish the two at runtime. Since it's possible for + # both ops to be "inlined", the fields could both be zero. To get + # around that, we hack op_next to be our own op (purely because we + # know it's a non-NULL pointer and can't be the same as op_other). + $init->add("((LOGOP*)$sym)->op_next = $sym;"); + runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next))); + $know_op = 0; + return $op->other; +} + +sub pp_mapwhile { + pp_grepwhile(@_); +} + +sub pp_return { + my $op = shift; + write_back_lexicals(REGISTER|TEMPORARY); + write_back_stack(); + doop($op); + runtime("PUTBACK;", "return 0;"); + $know_op = 0; + return $op->next; +} + +sub nyi { + my $op = shift; + warn sprintf("%s not yet implemented properly\n", $op->ppaddr); + return default_pp($op); +} + +sub pp_range { + my $op = shift; + my $flags = $op->flags; + if (!($flags & OPf_KNOW)) { + error("context of range unknown at compile-time"); + } + write_back_lexicals(); + write_back_stack(); + if (!($flags & OPf_LIST)) { + # We need to save our UNOP structure since pp_flop uses + # it to find and adjust out targ. We don't need it ourselves. + $op->save; + runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;", + $op->targ, label($op->false)); + unshift(@bblock_todo, $op->false); + } + return $op->true; +} + +sub pp_flip { + my $op = shift; + my $flags = $op->flags; + if (!($flags & OPf_KNOW)) { + error("context of flip unknown at compile-time"); + } + if ($flags & OPf_LIST) { + return $op->first->false; + } + write_back_lexicals(); + write_back_stack(); + # We need to save our UNOP structure since pp_flop uses + # it to find and adjust out targ. We don't need it ourselves. + $op->save; + my $ix = $op->targ; + my $rangeix = $op->first->targ; + runtime(($op->private & OPpFLIP_LINENUM) ? + "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {" + : "if (SvTRUE(TOPs)) {"); + runtime("\tsv_setiv(PL_curpad[$rangeix], 1);"); + if ($op->flags & OPf_SPECIAL) { + runtime("sv_setiv(PL_curpad[$ix], 1);"); + } else { + runtime("\tsv_setiv(PL_curpad[$ix], 0);", + "\tsp--;", + sprintf("\tgoto %s;", label($op->first->false))); + } + runtime("}", + qq{sv_setpv(PL_curpad[$ix], "");}, + "SETs(PL_curpad[$ix]);"); + $know_op = 0; + return $op->next; +} + +sub pp_flop { + my $op = shift; + default_pp($op); + $know_op = 0; + return $op->next; +} + +sub enterloop { + my $op = shift; + my $nextop = $op->nextop; + my $lastop = $op->lastop; + my $redoop = $op->redoop; + $curcop->write_back; + debug "enterloop: pushing on cxstack" if $debug_cxstack; + push(@cxstack, { + type => CXt_LOOP, + op => $op, + "label" => $curcop->[0]->label, + nextop => $nextop, + lastop => $lastop, + redoop => $redoop + }); + $nextop->save; + $lastop->save; + $redoop->save; + return default_pp($op); +} + +sub pp_enterloop { enterloop(@_) } +sub pp_enteriter { enterloop(@_) } + +sub pp_leaveloop { + my $op = shift; + if (!@cxstack) { + die "panic: leaveloop"; + } + debug "leaveloop: popping from cxstack" if $debug_cxstack; + pop(@cxstack); + return default_pp($op); +} + +sub pp_next { + my $op = shift; + my $cxix; + if ($op->flags & OPf_SPECIAL) { + $cxix = dopoptoloop(); + if ($cxix < 0) { + error('"next" used outside loop'); + return $op->next; # ignore the op + } + } else { + $cxix = dopoptolabel($op->pv); + if ($cxix < 0) { + error('Label not found at compile time for "next %s"', $op->pv); + return $op->next; # ignore the op + } + } + default_pp($op); + my $nextop = $cxstack[$cxix]->{nextop}; + push(@bblock_todo, $nextop); + runtime(sprintf("goto %s;", label($nextop))); + return $op->next; +} + +sub pp_redo { + my $op = shift; + my $cxix; + if ($op->flags & OPf_SPECIAL) { + $cxix = dopoptoloop(); + if ($cxix < 0) { + error('"redo" used outside loop'); + return $op->next; # ignore the op + } + } else { + $cxix = dopoptolabel($op->pv); + if ($cxix < 0) { + error('Label not found at compile time for "redo %s"', $op->pv); + return $op->next; # ignore the op + } + } + default_pp($op); + my $redoop = $cxstack[$cxix]->{redoop}; + push(@bblock_todo, $redoop); + runtime(sprintf("goto %s;", label($redoop))); + return $op->next; +} + +sub pp_last { + my $op = shift; + my $cxix; + if ($op->flags & OPf_SPECIAL) { + $cxix = dopoptoloop(); + if ($cxix < 0) { + error('"last" used outside loop'); + return $op->next; # ignore the op + } + } else { + $cxix = dopoptolabel($op->pv); + if ($cxix < 0) { + error('Label not found at compile time for "last %s"', $op->pv); + return $op->next; # ignore the op + } + # XXX Add support for "last" to leave non-loop blocks + if ($cxstack[$cxix]->{type} != CXt_LOOP) { + error('Use of "last" for non-loop blocks is not yet implemented'); + return $op->next; # ignore the op + } + } + default_pp($op); + my $lastop = $cxstack[$cxix]->{lastop}->next; + push(@bblock_todo, $lastop); + runtime(sprintf("goto %s;", label($lastop))); + return $op->next; +} + +sub pp_subst { + my $op = shift; + write_back_lexicals(); + write_back_stack(); + my $sym = doop($op); + my $replroot = $op->pmreplroot; + if ($$replroot) { + runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;", + $sym, label($replroot)); + $op->pmreplstart->save; + push(@bblock_todo, $replroot); + } + invalidate_lexicals(); + return $op->next; +} + +sub pp_substcont { + my $op = shift; + write_back_lexicals(); + write_back_stack(); + doop($op); + my $pmop = $op->other; + warn sprintf("substcont: op = %s, pmop = %s\n", + peekop($op), peekop($pmop));#debug +# my $pmopsym = objsym($pmop); + my $pmopsym = $pmop->save; # XXX can this recurse? + warn "pmopsym = $pmopsym\n";#debug + runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;", + $pmopsym, label($pmop->pmreplstart)); + invalidate_lexicals(); + return $pmop->next; +} + +sub default_pp { + my $op = shift; + my $ppname = $op->ppaddr; + write_back_lexicals() unless $skip_lexicals{$ppname}; + write_back_stack() unless $skip_stack{$ppname}; + doop($op); + # XXX If the only way that ops can write to a TEMPORARY lexical is + # when it's named in $op->targ then we could call + # invalidate_lexicals(TEMPORARY) and avoid having to write back all + # the temporaries. For now, we'll play it safe and write back the lot. + invalidate_lexicals() unless $skip_invalidate{$ppname}; + return $op->next; +} + +sub compile_op { + my $op = shift; + my $ppname = $op->ppaddr; + if (exists $ignore_op{$ppname}) { + return $op->next; + } + debug peek_stack() if $debug_stack; + if ($debug_op) { + debug sprintf("%s [%s]\n", + peekop($op), + $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ); + } + no strict 'refs'; + if (defined(&$ppname)) { + $know_op = 0; + return &$ppname($op); + } else { + return default_pp($op); + } +} + +sub compile_bblock { + my $op = shift; + #warn "compile_bblock: ", peekop($op), "\n"; # debug + write_label($op); + $know_op = 0; + do { + $op = compile_op($op); + } while (defined($op) && $$op && !exists($leaders->{$$op})); + write_back_stack(); # boo hoo: big loss + reload_lexicals(); + return $op; +} + +sub cc { + my ($name, $root, $start, @padlist) = @_; + my $op; + init_pp($name); + load_pad(@padlist); + B::Pseudoreg->new_scope; + @cxstack = (); + if ($debug_timings) { + warn sprintf("Basic block analysis at %s\n", timing_info); + } + $leaders = find_leaders($root, $start); + @bblock_todo = ($start, values %$leaders); + if ($debug_timings) { + warn sprintf("Compilation at %s\n", timing_info); + } + while (@bblock_todo) { + $op = shift @bblock_todo; + #warn sprintf("Considering basic block %s\n", peekop($op)); # debug + next if !defined($op) || !$$op || $done{$$op}; + #warn "...compiling it\n"; # debug + do { + $done{$$op} = 1; + $op = compile_bblock($op); + if ($need_freetmps && $freetmps_each_bblock) { + runtime("FREETMPS;"); + $need_freetmps = 0; + } + } while defined($op) && $$op && !$done{$$op}; + if ($need_freetmps && $freetmps_each_loop) { + runtime("FREETMPS;"); + $need_freetmps = 0; + } + if (!$$op) { + runtime("PUTBACK;", "return 0;"); + } elsif ($done{$$op}) { + runtime(sprintf("goto %s;", label($op))); + } + } + if ($debug_timings) { + warn sprintf("Saving runtime at %s\n", timing_info); + } + save_runtime(); +} + +sub cc_recurse { + my $ccinfo; + my $start; + $start = cc_queue(@_) if @_; + while ($ccinfo = shift @cc_todo) { + cc(@$ccinfo); + } + return $start; +} + +sub cc_obj { + my ($name, $cvref) = @_; + my $cv = svref_2object($cvref); + my @padlist = $cv->PADLIST->ARRAY; + my $curpad_sym = $padlist[1]->save; + cc_recurse($name, $cv->ROOT, $cv->START, @padlist); +} + +sub cc_main { + my @comppadlist = comppadlist->ARRAY; + my $curpad_sym = $comppadlist[1]->save; + my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist); + save_unused_subs(@unused_sub_packages); + cc_recurse(); + + return if $errors; + if (!defined($module)) { + $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), + "PL_main_start = $start;", + "PL_curpad = AvARRAY($curpad_sym);"); + } + output_boilerplate(); + print "\n"; + output_all("perl_init"); + output_runtime(); + print "\n"; + output_main(); + if (defined($module)) { + my $cmodule = $module; + $cmodule =~ s/::/__/g; + print <<"EOT"; + +#include "XSUB.h" +XS(boot_$cmodule) +{ + dXSARGS; + perl_init(); + ENTER; + SAVETMPS; + SAVESPTR(PL_curpad); + SAVESPTR(PL_op); + PL_curpad = AvARRAY($curpad_sym); + PL_op = $start; + pp_main(ARGS); + FREETMPS; + LEAVE; + ST(0) = &PL_sv_yes; + XSRETURN(1); +} +EOT + } + if ($debug_timings) { + warn sprintf("Done at %s\n", timing_info); + } +} + +sub compile { + my @options = @_; + my ($option, $opt, $arg); + OPTION: + while ($option = shift @options) { + if ($option =~ /^-(.)(.*)/) { + $opt = $1; + $arg = $2; + } else { + unshift @options, $option; + last OPTION; + } + if ($opt eq "-" && $arg eq "-") { + shift @options; + last OPTION; + } elsif ($opt eq "o") { + $arg ||= shift @options; + open(STDOUT, ">$arg") or return "open '>$arg': $!\n"; + } elsif ($opt eq "n") { + $arg ||= shift @options; + $module_name = $arg; + } elsif ($opt eq "u") { + $arg ||= shift @options; + push(@unused_sub_packages, $arg); + } elsif ($opt eq "f") { + $arg ||= shift @options; + my $value = $arg !~ s/^no-//; + $arg =~ s/-/_/g; + my $ref = $optimise{$arg}; + if (defined($ref)) { + $$ref = $value; + } else { + warn qq(ignoring unknown optimisation option "$arg"\n); + } + } elsif ($opt eq "O") { + $arg = 1 if $arg eq ""; + my $ref; + foreach $ref (values %optimise) { + $$ref = 0; + } + if ($arg >= 2) { + $freetmps_each_loop = 1; + } + if ($arg >= 1) { + $freetmps_each_bblock = 1 unless $freetmps_each_loop; + } + } elsif ($opt eq "m") { + $arg ||= shift @options; + $module = $arg; + push(@unused_sub_packages, $arg); + } elsif ($opt eq "p") { + $arg ||= shift @options; + $patchlevel = $arg; + } elsif ($opt eq "D") { + $arg ||= shift @options; + foreach $arg (split(//, $arg)) { + if ($arg eq "o") { + B->debug(1); + } elsif ($arg eq "O") { + $debug_op = 1; + } elsif ($arg eq "s") { + $debug_stack = 1; + } elsif ($arg eq "c") { + $debug_cxstack = 1; + } elsif ($arg eq "p") { + $debug_pad = 1; + } elsif ($arg eq "r") { + $debug_runtime = 1; + } elsif ($arg eq "S") { + $debug_shadow = 1; + } elsif ($arg eq "q") { + $debug_queue = 1; + } elsif ($arg eq "l") { + $debug_lineno = 1; + } elsif ($arg eq "t") { + $debug_timings = 1; + } + } + } + } + init_sections(); + $init = B::Section->get("init"); + $decl = B::Section->get("decl"); + + if (@options) { + return sub { + my ($objname, $ppname); + foreach $objname (@options) { + $objname = "main::$objname" unless $objname =~ /::/; + ($ppname = $objname) =~ s/^.*?:://; + eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)"; + die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@; + return if $errors; + } + output_boilerplate(); + print "\n"; + output_all($module_name || "init_module"); + output_runtime(); + } + } else { + return sub { cc_main() }; + } +} + +1; + +__END__ + +=head1 NAME + +B::CC - Perl compiler's optimized C translation backend + +=head1 SYNOPSIS + + perl -MO=CC[,OPTIONS] foo.pl + +=head1 DESCRIPTION + +This compiler backend takes Perl source and generates C source code +corresponding to the flow of your program. In other words, this +backend is somewhat a "real" compiler in the sense that many people +think about compilers. Note however that, currently, it is a very +poor compiler in that although it generates (mostly, or at least +sometimes) correct code, it performs relatively few optimisations. +This will change as the compiler develops. The result is that +running an executable compiled with this backend may start up more +quickly than running the original Perl program (a feature shared +by the B compiler backend--see F) and may also execute +slightly faster. This is by no means a good optimising compiler--yet. + +=head1 OPTIONS + +If there are any non-option arguments, they are taken to be +names of objects to be saved (probably doesn't work properly yet). +Without extra arguments, it saves the main program. + +=over 4 + +=item B<-ofilename> + +Output to filename instead of STDOUT + +=item B<-v> + +Verbose compilation (currently gives a few compilation statistics). + +=item B<--> + +Force end of options + +=item B<-uPackname> + +Force apparently unused subs from package Packname to be compiled. +This allows programs to use eval "foo()" even when sub foo is never +seen to be used at compile time. The down side is that any subs which +really are never used also have code generated. This option is +necessary, for example, if you have a signal handler foo which you +initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just +to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u> +options. The compiler tries to figure out which packages may possibly +have subs in which need compiling but the current version doesn't do +it very well. In particular, it is confused by nested packages (i.e. +of the form C) where package C does not contain any subs. + +=item B<-mModulename> + +Instead of generating source for a runnable executable, generate +source for an XSUB module. The boot_Modulename function (which +DynaLoader can look for) does the appropriate initialisation and runs +the main part of the Perl source that is being compiled. + + +=item B<-D> + +Debug options (concatenated or separate flags like C). + +=item B<-Dr> + +Writes debugging output to STDERR just as it's about to write to the +program's runtime (otherwise writes debugging info as comments in +its C output). + +=item B<-DO> + +Outputs each OP as it's compiled + +=item B<-Ds> + +Outputs the contents of the shadow stack at each OP + +=item B<-Dp> + +Outputs the contents of the shadow pad of lexicals as it's loaded for +each sub or the main program. + +=item B<-Dq> + +Outputs the name of each fake PP function in the queue as it's about +to process it. + +=item B<-Dl> + +Output the filename and line number of each original line of Perl +code as it's processed (C). + +=item B<-Dt> + +Outputs timing information of compilation stages. + +=item B<-f> + +Force optimisations on or off one at a time. + +=item B<-ffreetmps-each-bblock> + +Delays FREETMPS from the end of each statement to the end of the each +basic block. + +=item B<-ffreetmps-each-loop> + +Delays FREETMPS from the end of each statement to the end of the group +of basic blocks forming a loop. At most one of the freetmps-each-* +options can be used. + +=item B<-fomit-taint> + +Omits generating code for handling perl's tainting mechanism. + +=item B<-On> + +Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. +Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2> +sets B<-ffreetmps-each-loop>. + +=back + +=head1 EXAMPLES + + perl -MO=CC,-O2,-ofoo.c foo.pl + perl cc_harness -o foo foo.c + +Note that C lives in the C subdirectory of your perl +library directory. The utility called C may also be used to +help make use of this compiler. + + perl -MO=CC,-mFoo,-oFoo.c Foo.pm + perl cc_harness -shared -c -o Foo.so Foo.c + +=head1 BUGS + +Plenty. Current status: experimental. + +=head1 DIFFERENCES + +These aren't really bugs but they are constructs which are heavily +tied to perl's compile-and-go implementation and with which this +compiler backend cannot cope. + +=head2 Loops + +Standard perl calculates the target of "next", "last", and "redo" +at run-time. The compiler calculates the targets at compile-time. +For example, the program + + sub skip_on_odd { next NUMBER if $_[0] % 2 } + NUMBER: for ($i = 0; $i < 5; $i++) { + skip_on_odd($i); + print $i; + } + +produces the output + + 024 + +with standard perl but gives a compile-time error with the compiler. + +=head2 Context of ".." + +The context (scalar or array) of the ".." operator determines whether +it behaves as a range or a flip/flop. Standard perl delays until +runtime the decision of which context it is in but the compiler needs +to know the context at compile-time. For example, + + @a = (4,6,1,0,0,1); + sub range { (shift @a)..(shift @a) } + print range(); + while (@a) { print scalar(range()) } + +generates the output + + 456123E0 + +with standard Perl but gives a compile-time error with compiled Perl. + +=head2 Arithmetic + +Compiled Perl programs use native C arithemtic much more frequently +than standard perl. Operations on large numbers or on boundary +cases may produce different behaviour. + +=head2 Deprecated features + +Features of standard perl such as C<$[> which have been deprecated +in standard perl since Perl5 was released have not been implemented +in the compiler. + +=head1 AUTHOR + +Malcolm Beattie, C + +=cut diff --git a/contrib/perl5/ext/B/B/Debug.pm b/contrib/perl5/ext/B/B/Debug.pm new file mode 100644 index 0000000..7754a5a --- /dev/null +++ b/contrib/perl5/ext/B/B/Debug.pm @@ -0,0 +1,283 @@ +package B::Debug; +use strict; +use B qw(peekop class walkoptree walkoptree_exec + main_start main_root cstring sv_undef); +use B::Asmdata qw(@specialsv_name); + +my %done_gv; + +sub B::OP::debug { + my ($op) = @_; + printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op->seq, $op->flags, $op->private; +%s (0x%lx) + op_next 0x%x + op_sibling 0x%x + op_ppaddr %s + op_targ %d + op_type %d + op_seq %d + op_flags %d + op_private %d +EOT +} + +sub B::UNOP::debug { + my ($op) = @_; + $op->B::OP::debug(); + printf "\top_first\t0x%x\n", ${$op->first}; +} + +sub B::BINOP::debug { + my ($op) = @_; + $op->B::UNOP::debug(); + printf "\top_last\t\t0x%x\n", ${$op->last}; +} + +sub B::LOGOP::debug { + my ($op) = @_; + $op->B::UNOP::debug(); + printf "\top_other\t0x%x\n", ${$op->other}; +} + +sub B::CONDOP::debug { + my ($op) = @_; + $op->B::UNOP::debug(); + printf "\top_true\t0x%x\n", ${$op->true}; + printf "\top_false\t0x%x\n", ${$op->false}; +} + +sub B::LISTOP::debug { + my ($op) = @_; + $op->B::BINOP::debug(); + printf "\top_children\t%d\n", $op->children; +} + +sub B::PMOP::debug { + my ($op) = @_; + $op->B::LISTOP::debug(); + printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot}; + printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart}; + printf "\top_pmnext\t0x%x\n", ${$op->pmnext}; + printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp); + printf "\top_pmflags\t0x%x\n", $op->pmflags; + $op->pmshort->debug; + $op->pmreplroot->debug; +} + +sub B::COP::debug { + my ($op) = @_; + $op->B::OP::debug(); + my ($filegv) = $op->filegv; + printf <<'EOT', $op->label, ${$op->stash}, $$filegv, $op->seq, $op->arybase, $op->line; + cop_label %s + cop_stash 0x%x + cop_filegv 0x%x + cop_seq %d + cop_arybase %d + cop_line %d +EOT + $filegv->debug; +} + +sub B::SVOP::debug { + my ($op) = @_; + $op->B::OP::debug(); + printf "\top_sv\t\t0x%x\n", ${$op->sv}; + $op->sv->debug; +} + +sub B::PVOP::debug { + my ($op) = @_; + $op->B::OP::debug(); + printf "\top_pv\t\t0x%x\n", $op->pv; +} + +sub B::GVOP::debug { + my ($op) = @_; + $op->B::OP::debug(); + printf "\top_gv\t\t0x%x\n", ${$op->gv}; + $op->gv->debug; +} + +sub B::CVOP::debug { + my ($op) = @_; + $op->B::OP::debug(); + printf "\top_cv\t\t0x%x\n", ${$op->cv}; +} + +sub B::NULL::debug { + my ($sv) = @_; + if ($$sv == ${sv_undef()}) { + print "&sv_undef\n"; + } else { + printf "NULL (0x%x)\n", $$sv; + } +} + +sub B::SV::debug { + my ($sv) = @_; + if (!$$sv) { + print class($sv), " = NULL\n"; + return; + } + printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS; +%s (0x%x) + REFCNT %d + FLAGS 0x%x +EOT +} + +sub B::PV::debug { + my ($sv) = @_; + $sv->B::SV::debug(); + my $pv = $sv->PV(); + printf <<'EOT', cstring($pv), length($pv); + xpv_pv %s + xpv_cur %d +EOT +} + +sub B::IV::debug { + my ($sv) = @_; + $sv->B::SV::debug(); + printf "\txiv_iv\t\t%d\n", $sv->IV; +} + +sub B::NV::debug { + my ($sv) = @_; + $sv->B::IV::debug(); + printf "\txnv_nv\t\t%s\n", $sv->NV; +} + +sub B::PVIV::debug { + my ($sv) = @_; + $sv->B::PV::debug(); + printf "\txiv_iv\t\t%d\n", $sv->IV; +} + +sub B::PVNV::debug { + my ($sv) = @_; + $sv->B::PVIV::debug(); + printf "\txnv_nv\t\t%s\n", $sv->NV; +} + +sub B::PVLV::debug { + my ($sv) = @_; + $sv->B::PVNV::debug(); + printf "\txlv_targoff\t%d\n", $sv->TARGOFF; + printf "\txlv_targlen\t%u\n", $sv->TARGLEN; + printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE)); +} + +sub B::BM::debug { + my ($sv) = @_; + $sv->B::PVNV::debug(); + printf "\txbm_useful\t%d\n", $sv->USEFUL; + printf "\txbm_previous\t%u\n", $sv->PREVIOUS; + printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE)); +} + +sub B::CV::debug { + my ($sv) = @_; + $sv->B::PVNV::debug(); + my ($stash) = $sv->STASH; + my ($start) = $sv->START; + my ($root) = $sv->ROOT; + my ($padlist) = $sv->PADLIST; + my ($gv) = $sv->GV; + my ($filegv) = $sv->FILEGV; + printf <<'EOT', $$stash, $$start, $$root, $$gv, $$filegv, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}; + STASH 0x%x + START 0x%x + ROOT 0x%x + GV 0x%x + FILEGV 0x%x + DEPTH %d + PADLIST 0x%x + OUTSIDE 0x%x +EOT + $start->debug if $start; + $root->debug if $root; + $gv->debug if $gv; + $filegv->debug if $filegv; + $padlist->debug if $padlist; +} + +sub B::AV::debug { + my ($av) = @_; + $av->B::SV::debug; + my(@array) = $av->ARRAY; + print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n"; + printf <<'EOT', scalar(@array), $av->MAX, $av->OFF, $av->AvFLAGS; + FILL %d + MAX %d + OFF %d + AvFLAGS %d +EOT +} + +sub B::GV::debug { + my ($gv) = @_; + if ($done_gv{$$gv}++) { + printf "GV %s::%s\n", $gv->STASH->NAME, $gv->NAME; + return; + } + my ($sv) = $gv->SV; + my ($av) = $gv->AV; + my ($cv) = $gv->CV; + $gv->B::SV::debug; + printf <<'EOT', $gv->NAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILEGV, $gv->GvFLAGS; + NAME %s + STASH %s (0x%x) + SV 0x%x + GvREFCNT %d + FORM 0x%x + AV 0x%x + HV 0x%x + EGV 0x%x + CV 0x%x + CVGEN %d + LINE %d + FILEGV 0x%x + GvFLAGS 0x%x +EOT + $sv->debug if $sv; + $av->debug if $av; + $cv->debug if $cv; +} + +sub B::SPECIAL::debug { + my $sv = shift; + print $specialsv_name[$$sv], "\n"; +} + +sub compile { + my $order = shift; + if ($order eq "exec") { + return sub { walkoptree_exec(main_start, "debug") } + } else { + return sub { walkoptree(main_root, "debug") } + } +} + +1; + +__END__ + +=head1 NAME + +B::Debug - Walk Perl syntax tree, printing debug info about ops + +=head1 SYNOPSIS + + perl -MO=Debug[,OPTIONS] foo.pl + +=head1 DESCRIPTION + +See F. + +=head1 AUTHOR + +Malcolm Beattie, C + +=cut diff --git a/contrib/perl5/ext/B/B/Deparse.pm b/contrib/perl5/ext/B/B/Deparse.pm new file mode 100644 index 0000000..5e0bd1d --- /dev/null +++ b/contrib/perl5/ext/B/B/Deparse.pm @@ -0,0 +1,2670 @@ +# B::Deparse.pm +# Copyright (c) 1998 Stephen McCamant. All rights reserved. +# This module is free software; you can redistribute and/or modify +# it under the same terms as Perl itself. + +# This is based on the module of the same name by Malcolm Beattie, +# but essentially none of his code remains. + +package B::Deparse; +use Carp 'cluck'; +use B qw(class main_root main_start main_cv svref_2object); +$VERSION = 0.56; +use strict; + +# Changes between 0.50 and 0.51: +# - fixed nulled leave with live enter in sort { } +# - fixed reference constants (\"str") +# - handle empty programs gracefully +# - handle infinte loops (for (;;) {}, while (1) {}) +# - differentiate between `for my $x ...' and `my $x; for $x ...' +# - various minor cleanups +# - moved globals into an object +# - added `-u', like B::C +# - package declarations using cop_stash +# - subs, formats and code sorted by cop_seq +# Changes between 0.51 and 0.52: +# - added pp_threadsv (special variables under USE_THREADS) +# - added documentation +# Changes between 0.52 and 0.53 +# - many changes adding precedence contexts and associativity +# - added `-p' and `-s' output style options +# - various other minor fixes +# Changes between 0.53 and 0.54 +# - added support for new `for (1..100)' optimization, +# thanks to Gisle Aas +# Changes between 0.54 and 0.55 +# - added support for new qr// construct +# - added support for new pp_regcreset OP +# Changes between 0.55 and 0.56 +# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t +# - fixed $# on non-lexicals broken in last big rewrite +# - added temporary fix for change in opcode of OP_STRINGIFY +# - fixed problem in 0.54's for() patch in `for (@ary)' +# - fixed precedence in conditional of ?: +# - tweaked list paren elimination in `my($x) = @_' +# - made continue-block detection trickier wrt. null ops +# - fixed various prototype problems in pp_entersub +# - added support for sub prototypes that never get GVs +# - added unquoting for special filehandle first arg in truncate +# - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV' +# - added semicolons at the ends of blocks +# - added -l `#line' declaration option -- fixes cmd/subval.t 27,28 + +# Todo: +# - {} around variables in strings ("${var}letters") +# base/lex.t 25-27 +# comp/term.t 11 +# - generate symbolic constants directly from core source +# - left/right context +# - avoid semis in one-statement blocks +# - associativity of &&=, ||=, ?: +# - ',' => '=>' (auto-unquote?) +# - break long lines ("\r" as discretionary break?) +# - include values of variables (e.g. set in BEGIN) +# - coordinate with Data::Dumper (both directions? see previous) +# - version using op_next instead of op_first/sibling? +# - avoid string copies (pass arrays, one big join?) +# - auto-apply `-u'? +# - while{} with one-statement continue => for(; XXX; XXX) {}? +# - -uPackage:: descend recursively? +# - here-docs? +# - ? + +# Tests that will always fail: +# comp/redef.t -- all (redefinition happens at compile time) + +# Object fields (were globals): +# +# avoid_local: +# (local($a), local($b)) and local($a, $b) have the same internal +# representation but the short form looks better. We notice we can +# use a large-scale local when checking the list, but need to prevent +# individual locals too. This hash holds the addresses of OPs that +# have already had their local-ness accounted for. The same thing +# is done with my(). +# +# curcv: +# CV for current sub (or main program) being deparsed +# +# curstash: +# name of the current package for deparsed code +# +# subs_todo: +# array of [cop_seq, GV, is_format?] for subs and formats we still +# want to deparse +# +# protos_todo: +# as above, but [name, prototype] for subs that never got a GV +# +# subs_done, forms_done: +# keys are addresses of GVs for subs and formats we've already +# deparsed (or at least put into subs_todo) +# +# parens: -p +# linenums: -l +# cuddle: ` ' or `\n', depending on -sC + +# A little explanation of how precedence contexts and associativity +# work: +# +# deparse() calls each per-op subroutine with an argument $cx (short +# for context, but not the same as the cx* in the perl core), which is +# a number describing the op's parents in terms of precedence, whether +# they're inside an expression or at statement level, etc. (see +# chart below). When ops with children call deparse on them, they pass +# along their precedence. Fractional values are used to implement +# associativity (`($x + $y) + $z' => `$x + $y + $y') and related +# parentheses hacks. The major disadvantage of this scheme is that +# it doesn't know about right sides and left sides, so say if you +# assign a listop to a variable, it can't tell it's allowed to leave +# the parens off the listop. + +# Precedences: +# 26 [TODO] inside interpolation context ("") +# 25 left terms and list operators (leftward) +# 24 left -> +# 23 nonassoc ++ -- +# 22 right ** +# 21 right ! ~ \ and unary + and - +# 20 left =~ !~ +# 19 left * / % x +# 18 left + - . +# 17 left << >> +# 16 nonassoc named unary operators +# 15 nonassoc < > <= >= lt gt le ge +# 14 nonassoc == != <=> eq ne cmp +# 13 left & +# 12 left | ^ +# 11 left && +# 10 left || +# 9 nonassoc .. ... +# 8 right ?: +# 7 right = += -= *= etc. +# 6 left , => +# 5 nonassoc list operators (rightward) +# 4 right not +# 3 left and +# 2 left or xor +# 1 statement modifiers +# 0 statement level + +# Nonprinting characters with special meaning: +# \cS - steal parens (see maybe_parens_unop) +# \n - newline and indent +# \t - increase indent +# \b - decrease indent (`outdent') +# \f - flush left (no indent) +# \cK - kill following semicolon, if any + +sub null { + my $op = shift; + return class($op) eq "NULL"; +} + +sub todo { + my $self = shift; + my($gv, $cv, $is_form) = @_; + my $seq; + if (!null($cv->START) and is_state($cv->START)) { + $seq = $cv->START->cop_seq; + } else { + $seq = 0; + } + push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form]; +} + +sub next_todo { + my $self = shift; + my $ent = shift @{$self->{'subs_todo'}}; + my $name = $self->gv_name($ent->[1]); + if ($ent->[2]) { + return "format $name =\n" + . $self->deparse_format($ent->[1]->FORM). "\n"; + } else { + return "sub $name " . + $self->deparse_sub($ent->[1]->CV); + } +} + +sub OPf_KIDS () { 4 } + +sub walk_tree { + my($op, $sub) = @_; + $sub->($op); + if ($op->flags & OPf_KIDS) { + my $kid; + for ($kid = $op->first; not null $kid; $kid = $kid->sibling) { + walk_tree($kid, $sub); + } + } +} + +sub walk_sub { + my $self = shift; + my $cv = shift; + my $op = $cv->ROOT; + $op = shift if null $op; + return if !$op or null $op; + walk_tree($op, sub { + my $op = shift; + if ($op->ppaddr eq "pp_gv") { + if ($op->next->ppaddr eq "pp_entersub") { + next if $self->{'subs_done'}{$ {$op->gv}}++; + next if class($op->gv->CV) eq "SPECIAL"; + $self->todo($op->gv, $op->gv->CV, 0); + $self->walk_sub($op->gv->CV); + } elsif ($op->next->ppaddr eq "pp_enterwrite" + or ($op->next->ppaddr eq "pp_rv2gv" + and $op->next->next->ppaddr eq "pp_enterwrite")) { + next if $self->{'forms_done'}{$ {$op->gv}}++; + next if class($op->gv->FORM) eq "SPECIAL"; + $self->todo($op->gv, $op->gv->FORM, 1); + $self->walk_sub($op->gv->FORM); + } + } + }); +} + +sub stash_subs { + my $self = shift; + my $pack = shift; + my(%stash, @ret); + { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY } + if ($pack eq "main") { + $pack = ""; + } else { + $pack = $pack . "::"; + } + my($key, $val); + while (($key, $val) = each %stash) { + my $class = class($val); + if ($class eq "PV") { + # Just a prototype + push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV]; + } elsif ($class eq "IV") { + # Just a name + push @{$self->{'protos_todo'}}, [$pack . $key, undef]; + } elsif ($class eq "GV") { + if (class($val->CV) ne "SPECIAL") { + next if $self->{'subs_done'}{$$val}++; + $self->todo($val, $val->CV, 0); + $self->walk_sub($val->CV); + } + if (class($val->FORM) ne "SPECIAL") { + next if $self->{'forms_done'}{$$val}++; + $self->todo($val, $val->FORM, 1); + $self->walk_sub($val->FORM); + } + } + } +} + +sub print_protos { + my $self = shift; + my $ar; + my @ret; + foreach $ar (@{$self->{'protos_todo'}}) { + my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : ""); + push @ret, "sub " . $ar->[0] . "$proto;\n"; + } + delete $self->{'protos_todo'}; + return @ret; +} + +sub style_opts { + my $self = shift; + my $opts = shift; + my $opt; + while (length($opt = substr($opts, 0, 1))) { + if ($opt eq "C") { + $self->{'cuddle'} = " "; + } + $opts = substr($opts, 1); + } +} + +sub compile { + my(@args) = @_; + return sub { + my $self = bless {}; + my $arg; + $self->{'subs_todo'} = []; + $self->stash_subs("main"); + $self->{'curcv'} = main_cv; + $self->{'curstash'} = "main"; + $self->{'cuddle'} = "\n"; + while ($arg = shift @args) { + if (substr($arg, 0, 2) eq "-u") { + $self->stash_subs(substr($arg, 2)); + } elsif ($arg eq "-p") { + $self->{'parens'} = 1; + } elsif ($arg eq "-l") { + $self->{'linenums'} = 1; + } elsif (substr($arg, 0, 2) eq "-s") { + $self->style_opts(substr $arg, 2); + } + } + $self->walk_sub(main_cv, main_start); + print $self->print_protos; + @{$self->{'subs_todo'}} = + sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}; + print indent($self->deparse(main_root, 0)), "\n" unless null main_root; + my @text; + while (scalar(@{$self->{'subs_todo'}})) { + push @text, $self->next_todo; + } + print indent(join("", @text)), "\n" if @text; + } +} + +sub deparse { + my $self = shift; + my($op, $cx) = @_; +# cluck if class($op) eq "NULL"; + my $meth = $op->ppaddr; + return $self->$meth($op, $cx); +} + +sub indent { + my $txt = shift; + my @lines = split(/\n/, $txt); + my $leader = ""; + my $line; + for $line (@lines) { + if (substr($line, 0, 1) eq "\t") { + $leader = $leader . " "; + $line = substr($line, 1); + } elsif (substr($line, 0, 1) eq "\b") { + $leader = substr($leader, 0, length($leader) - 4); + $line = substr($line, 1); + } + if (substr($line, 0, 1) eq "\f") { + $line = substr($line, 1); # no indent + } else { + $line = $leader . $line; + } + $line =~ s/\cK;?//g; + } + return join("\n", @lines); +} + +sub SVf_POK () {0x40000} + +sub deparse_sub { + my $self = shift; + my $cv = shift; + my $proto = ""; + if ($cv->FLAGS & SVf_POK) { + $proto = "(". $cv->PV . ") "; + } + local($self->{'curcv'}) = $cv; + local($self->{'curstash'}) = $self->{'curstash'}; + if (not null $cv->ROOT) { + # skip leavesub + return $proto . "{\n\t" . + $self->deparse($cv->ROOT->first, 0) . "\n\b}\n"; + } else { # XSUB? + return $proto . "{}\n"; + } +} + +sub deparse_format { + my $self = shift; + my $form = shift; + my @text; + local($self->{'curcv'}) = $form; + local($self->{'curstash'}) = $self->{'curstash'}; + my $op = $form->ROOT; + my $kid; + $op = $op->first->first; # skip leavewrite, lineseq + while (not null $op) { + $op = $op->sibling; # skip nextstate + my @exprs; + $kid = $op->first->sibling; # skip pushmark + push @text, $kid->sv->PV; + $kid = $kid->sibling; + for (; not null $kid; $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, 0); + } + push @text, join(", ", @exprs)."\n" if @exprs; + $op = $op->sibling; + } + return join("", @text) . "."; +} + +# the aassign in-common check messes up SvCUR (always setting it +# to a value >= 100), but it's probably safe to assume there +# won't be any NULs in the names of my() variables. (with +# stash variables, I wouldn't be so sure) +sub padname_fix { + my $str = shift; + $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1; + return $str; +} + +sub is_scope { + my $op = shift; + return $op->ppaddr eq "pp_leave" || $op->ppaddr eq "pp_scope" + || $op->ppaddr eq "pp_lineseq" + || ($op->ppaddr eq "pp_null" && class($op) eq "UNOP" + && (is_scope($op->first) || $op->first->ppaddr eq "pp_enter")); +} + +sub is_state { + my $name = $_[0]->ppaddr; + return $name eq "pp_nextstate" || $name eq "pp_dbstate"; +} + +sub is_miniwhile { # check for one-line loop (`foo() while $y--') + my $op = shift; + return (!null($op) and null($op->sibling) + and $op->ppaddr eq "pp_null" and class($op) eq "UNOP" + and (($op->first->ppaddr =~ /^pp_(and|or)$/ + and $op->first->first->sibling->ppaddr eq "pp_lineseq") + or ($op->first->ppaddr eq "pp_lineseq" + and not null $op->first->first->sibling + and $op->first->first->sibling->ppaddr eq "pp_unstack") + )); +} + +sub is_scalar { + my $op = shift; + return ($op->ppaddr eq "pp_rv2sv" or + $op->ppaddr eq "pp_padsv" or + $op->ppaddr eq "pp_gv" or # only in array/hash constructs + !null($op->first) && $op->first->ppaddr eq "pp_gvsv"); +} + +sub maybe_parens { + my $self = shift; + my($text, $cx, $prec) = @_; + if ($prec < $cx # unary ops nest just fine + or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21 + or $self->{'parens'}) + { + $text = "($text)"; + # In a unop, let parent reuse our parens; see maybe_parens_unop + $text = "\cS" . $text if $cx == 16; + return $text; + } else { + return $text; + } +} + +# same as above, but get around the `if it looks like a function' rule +sub maybe_parens_unop { + my $self = shift; + my($name, $kid, $cx) = @_; + if ($cx > 16 or $self->{'parens'}) { + return "$name(" . $self->deparse($kid, 1) . ")"; + } else { + $kid = $self->deparse($kid, 16); + if (substr($kid, 0, 1) eq "\cS") { + # use kid's parens + return $name . substr($kid, 1); + } elsif (substr($kid, 0, 1) eq "(") { + # avoid looks-like-a-function trap with extra parens + # (`+' can lead to ambiguities) + return "$name(" . $kid . ")"; + } else { + return "$name $kid"; + } + } +} + +sub maybe_parens_func { + my $self = shift; + my($func, $text, $cx, $prec) = @_; + if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) { + return "$func($text)"; + } else { + return "$func $text"; + } +} + +sub OPp_LVAL_INTRO () { 128 } + +sub maybe_local { + my $self = shift; + my($op, $cx, $text) = @_; + if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) { + return $self->maybe_parens_func("local", $text, $cx, 16); + } else { + return $text; + } +} + +sub padname_sv { + my $self = shift; + my $targ = shift; + return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ]; +} + +sub maybe_my { + my $self = shift; + my($op, $cx, $text) = @_; + if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) { + return $self->maybe_parens_func("my", $text, $cx, 16); + } else { + return $text; + } +} + +# The following OPs don't have functions: + +# pp_padany -- does not exist after parsing +# pp_rcatline -- does not exist + +sub pp_enter { # see also leave + cluck "unexpected OP_ENTER"; + return "XXX"; +} + +sub pp_pushmark { # see also list + cluck "unexpected OP_PUSHMARK"; + return "XXX"; +} + +sub pp_leavesub { # see also deparse_sub + cluck "unexpected OP_LEAVESUB"; + return "XXX"; +} + +sub pp_leavewrite { # see also deparse_format + cluck "unexpected OP_LEAVEWRITE"; + return "XXX"; +} + +sub pp_method { # see also entersub + cluck "unexpected OP_METHOD"; + return "XXX"; +} + +sub pp_regcmaybe { # see also regcomp + cluck "unexpected OP_REGCMAYBE"; + return "XXX"; +} + +sub pp_regcreset { # see also regcomp + cluck "unexpected OP_REGCRESET"; + return "XXX"; +} + +sub pp_substcont { # see also subst + cluck "unexpected OP_SUBSTCONT"; + return "XXX"; +} + +sub pp_grepstart { # see also grepwhile + cluck "unexpected OP_GREPSTART"; + return "XXX"; +} + +sub pp_mapstart { # see also mapwhile + cluck "unexpected OP_MAPSTART"; + return "XXX"; +} + +sub pp_flip { # see also flop + cluck "unexpected OP_FLIP"; + return "XXX"; +} + +sub pp_iter { # see also leaveloop + cluck "unexpected OP_ITER"; + return "XXX"; +} + +sub pp_enteriter { # see also leaveloop + cluck "unexpected OP_ENTERITER"; + return "XXX"; +} + +sub pp_enterloop { # see also leaveloop + cluck "unexpected OP_ENTERLOOP"; + return "XXX"; +} + +sub pp_leaveeval { # see also entereval + cluck "unexpected OP_LEAVEEVAL"; + return "XXX"; +} + +sub pp_entertry { # see also leavetry + cluck "unexpected OP_ENTERTRY"; + return "XXX"; +} + +# leave and scope/lineseq should probably share code +sub pp_leave { + my $self = shift; + my($op, $cx) = @_; + my ($kid, $expr); + my @exprs; + local($self->{'curstash'}) = $self->{'curstash'}; + $kid = $op->first->sibling; # skip enter + if (is_miniwhile($kid)) { + my $top = $kid->first; + my $name = $top->ppaddr; + if ($name eq "pp_and") { + $name = "while"; + } elsif ($name eq "pp_or") { + $name = "until"; + } else { # no conditional -> while 1 or until 0 + return $self->deparse($top->first, 1) . " while 1"; + } + my $cond = $top->first; + my $body = $cond->sibling->first; # skip lineseq + $cond = $self->deparse($cond, 1); + $body = $self->deparse($body, 1); + return "$body $name $cond"; + } + for (; !null($kid); $kid = $kid->sibling) { + $expr = ""; + if (is_state $kid) { + $expr = $self->deparse($kid, 0); + $kid = $kid->sibling; + last if null $kid; + } + $expr .= $self->deparse($kid, 0); + push @exprs, $expr if $expr; + } + if ($cx > 0) { # inside an expression + return "do { " . join(";\n", @exprs) . " }"; + } else { + return join(";\n", @exprs) . ";"; + } +} + +sub pp_scope { + my $self = shift; + my($op, $cx) = @_; + my ($kid, $expr); + my @exprs; + for ($kid = $op->first; !null($kid); $kid = $kid->sibling) { + $expr = ""; + if (is_state $kid) { + $expr = $self->deparse($kid, 0); + $kid = $kid->sibling; + last if null $kid; + } + $expr .= $self->deparse($kid, 0); + push @exprs, $expr if $expr; + } + if ($cx > 0) { # inside an expression, (a do {} while for lineseq) + return "do { " . join(";\n", @exprs) . " }"; + } else { + return join(";\n", @exprs) . ";"; + } +} + +sub pp_lineseq { pp_scope(@_) } + +# The BEGIN {} is used here because otherwise this code isn't executed +# when you run B::Deparse on itself. +my %globalnames; +BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC", + "ENV", "ARGV", "ARGVOUT", "_"); } + +sub gv_name { + my $self = shift; + my $gv = shift; + my $stash = $gv->STASH->NAME; + my $name = $gv->NAME; + if ($stash eq $self->{'curstash'} or $globalnames{$name} + or $name =~ /^[^A-Za-z_]/) + { + $stash = ""; + } else { + $stash = $stash . "::"; + } + if ($name =~ /^([\cA-\cZ])$/) { + $name = "^" . chr(64 + ord($1)); + } + return $stash . $name; +} + +# Notice how subs and formats are inserted between statements here +sub pp_nextstate { + my $self = shift; + my($op, $cx) = @_; + my @text; + @text = $op->label . ": " if $op->label; + my $seq = $op->cop_seq; + while (scalar(@{$self->{'subs_todo'}}) + and $seq > $self->{'subs_todo'}[0][0]) { + push @text, $self->next_todo; + } + my $stash = $op->stash->NAME; + if ($stash ne $self->{'curstash'}) { + push @text, "package $stash;\n"; + $self->{'curstash'} = $stash; + } + if ($self->{'linenums'}) { + push @text, "\f#line " . $op->line . + ' "' . substr($op->filegv->NAME, 2), qq'"\n'; + } + return join("", @text); +} + +sub pp_dbstate { pp_nextstate(@_) } + +sub pp_unstack { return "" } # see also leaveloop + +sub baseop { + my $self = shift; + my($op, $cx, $name) = @_; + return $name; +} + +sub pp_stub { baseop(@_, "()") } +sub pp_wantarray { baseop(@_, "wantarray") } +sub pp_fork { baseop(@_, "fork") } +sub pp_wait { baseop(@_, "wait") } +sub pp_getppid { baseop(@_, "getppid") } +sub pp_time { baseop(@_, "time") } +sub pp_tms { baseop(@_, "times") } +sub pp_ghostent { baseop(@_, "gethostent") } +sub pp_gnetent { baseop(@_, "getnetent") } +sub pp_gprotoent { baseop(@_, "getprotoent") } +sub pp_gservent { baseop(@_, "getservent") } +sub pp_ehostent { baseop(@_, "endhostent") } +sub pp_enetent { baseop(@_, "endnetent") } +sub pp_eprotoent { baseop(@_, "endprotoent") } +sub pp_eservent { baseop(@_, "endservent") } +sub pp_gpwent { baseop(@_, "getpwent") } +sub pp_spwent { baseop(@_, "setpwent") } +sub pp_epwent { baseop(@_, "endpwent") } +sub pp_ggrent { baseop(@_, "getgrent") } +sub pp_sgrent { baseop(@_, "setgrent") } +sub pp_egrent { baseop(@_, "endgrent") } +sub pp_getlogin { baseop(@_, "getlogin") } + +sub POSTFIX () { 1 } + +# I couldn't think of a good short name, but this is the category of +# symbolic unary operators with interesting precedence + +sub pfixop { + my $self = shift; + my($op, $cx, $name, $prec, $flags) = (@_, 0); + my $kid = $op->first; + $kid = $self->deparse($kid, $prec); + return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid", + $cx, $prec); +} + +sub pp_preinc { pfixop(@_, "++", 23) } +sub pp_predec { pfixop(@_, "--", 23) } +sub pp_postinc { pfixop(@_, "++", 23, POSTFIX) } +sub pp_postdec { pfixop(@_, "--", 23, POSTFIX) } +sub pp_i_preinc { pfixop(@_, "++", 23) } +sub pp_i_predec { pfixop(@_, "--", 23) } +sub pp_i_postinc { pfixop(@_, "++", 23, POSTFIX) } +sub pp_i_postdec { pfixop(@_, "--", 23, POSTFIX) } +sub pp_complement { pfixop(@_, "~", 21) } + +sub pp_negate { + my $self = shift; + my($op, $cx) = @_; + if ($op->first->ppaddr =~ /^pp_(i_)?negate$/) { + # avoid --$x + $self->pfixop($op, $cx, "-", 21.5); + } else { + $self->pfixop($op, $cx, "-", 21); + } +} +sub pp_i_negate { pp_negate(@_) } + +sub pp_not { + my $self = shift; + my($op, $cx) = @_; + if ($cx <= 4) { + $self->pfixop($op, $cx, "not ", 4); + } else { + $self->pfixop($op, $cx, "!", 21); + } +} + +sub OPf_SPECIAL () { 128 } + +sub unop { + my $self = shift; + my($op, $cx, $name, $prec, $flags) = (@_, 0, 0); + my $kid; + if ($op->flags & OPf_KIDS) { + $kid = $op->first; + return $self->maybe_parens_unop($name, $kid, $cx); + } else { + return $name . ($op->flags & OPf_SPECIAL ? "()" : ""); + } +} + +sub pp_chop { unop(@_, "chop") } +sub pp_chomp { unop(@_, "chomp") } +sub pp_schop { unop(@_, "chop") } +sub pp_schomp { unop(@_, "chomp") } +sub pp_defined { unop(@_, "defined") } +sub pp_undef { unop(@_, "undef") } +sub pp_study { unop(@_, "study") } +sub pp_ref { unop(@_, "ref") } +sub pp_pos { maybe_local(@_, unop(@_, "pos")) } + +sub pp_sin { unop(@_, "sin") } +sub pp_cos { unop(@_, "cos") } +sub pp_rand { unop(@_, "rand") } +sub pp_srand { unop(@_, "srand") } +sub pp_exp { unop(@_, "exp") } +sub pp_log { unop(@_, "log") } +sub pp_sqrt { unop(@_, "sqrt") } +sub pp_int { unop(@_, "int") } +sub pp_hex { unop(@_, "hex") } +sub pp_oct { unop(@_, "oct") } +sub pp_abs { unop(@_, "abs") } + +sub pp_length { unop(@_, "length") } +sub pp_ord { unop(@_, "ord") } +sub pp_chr { unop(@_, "chr") } +sub pp_ucfirst { unop(@_, "ucfirst") } +sub pp_lcfirst { unop(@_, "lcfirst") } +sub pp_uc { unop(@_, "uc") } +sub pp_lc { unop(@_, "lc") } +sub pp_quotemeta { unop(@_, "quotemeta") } + +sub pp_each { unop(@_, "each") } +sub pp_values { unop(@_, "values") } +sub pp_keys { unop(@_, "keys") } +sub pp_pop { unop(@_, "pop") } +sub pp_shift { unop(@_, "shift") } + +sub pp_caller { unop(@_, "caller") } +sub pp_reset { unop(@_, "reset") } +sub pp_exit { unop(@_, "exit") } +sub pp_prototype { unop(@_, "prototype") } + +sub pp_close { unop(@_, "close") } +sub pp_fileno { unop(@_, "fileno") } +sub pp_umask { unop(@_, "umask") } +sub pp_binmode { unop(@_, "binmode") } +sub pp_untie { unop(@_, "untie") } +sub pp_tied { unop(@_, "tied") } +sub pp_dbmclose { unop(@_, "dbmclose") } +sub pp_getc { unop(@_, "getc") } +sub pp_eof { unop(@_, "eof") } +sub pp_tell { unop(@_, "tell") } +sub pp_getsockname { unop(@_, "getsockname") } +sub pp_getpeername { unop(@_, "getpeername") } + +sub pp_chdir { unop(@_, "chdir") } +sub pp_chroot { unop(@_, "chroot") } +sub pp_readlink { unop(@_, "readlink") } +sub pp_rmdir { unop(@_, "rmdir") } +sub pp_readdir { unop(@_, "readdir") } +sub pp_telldir { unop(@_, "telldir") } +sub pp_rewinddir { unop(@_, "rewinddir") } +sub pp_closedir { unop(@_, "closedir") } +sub pp_getpgrp { unop(@_, "getpgrp") } +sub pp_localtime { unop(@_, "localtime") } +sub pp_gmtime { unop(@_, "gmtime") } +sub pp_alarm { unop(@_, "alarm") } +sub pp_sleep { unop(@_, "sleep") } + +sub pp_dofile { unop(@_, "do") } +sub pp_entereval { unop(@_, "eval") } + +sub pp_ghbyname { unop(@_, "gethostbyname") } +sub pp_gnbyname { unop(@_, "getnetbyname") } +sub pp_gpbyname { unop(@_, "getprotobyname") } +sub pp_shostent { unop(@_, "sethostent") } +sub pp_snetent { unop(@_, "setnetent") } +sub pp_sprotoent { unop(@_, "setprotoent") } +sub pp_sservent { unop(@_, "setservent") } +sub pp_gpwnam { unop(@_, "getpwnam") } +sub pp_gpwuid { unop(@_, "getpwuid") } +sub pp_ggrnam { unop(@_, "getgrnam") } +sub pp_ggrgid { unop(@_, "getgrgid") } + +sub pp_lock { unop(@_, "lock") } + +sub pp_exists { + my $self = shift; + my($op, $cx) = @_; + return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16), + $cx, 16); +} + +sub OPpSLICE () { 64 } + +sub pp_delete { + my $self = shift; + my($op, $cx) = @_; + my $arg; + if ($op->private & OPpSLICE) { + return $self->maybe_parens_func("delete", + $self->pp_hslice($op->first, 16), + $cx, 16); + } else { + return $self->maybe_parens_func("delete", + $self->pp_helem($op->first, 16), + $cx, 16); + } +} + +sub OPp_CONST_BARE () { 64 } + +sub pp_require { + my $self = shift; + my($op, $cx) = @_; + if (class($op) eq "UNOP" and $op->first->ppaddr eq "pp_const" + and $op->first->private & OPp_CONST_BARE) + { + my $name = $op->first->sv->PV; + $name =~ s[/][::]g; + $name =~ s/\.pm//g; + return "require($name)"; + } else { + $self->unop($op, $cx, "require"); + } +} + +sub pp_scalar { + my $self = shift; + my($op, $cv) = @_; + my $kid = $op->first; + if (not null $kid->sibling) { + # XXX Was a here-doc + return $self->dquote($op); + } + $self->unop(@_, "scalar"); +} + + +sub padval { + my $self = shift; + my $targ = shift; + return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ]; +} + +sub OPf_REF () { 16 } + +sub pp_refgen { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first; + if ($kid->ppaddr eq "pp_null") { + $kid = $kid->first; + if ($kid->ppaddr eq "pp_anonlist" || $kid->ppaddr eq "pp_anonhash") { + my($pre, $post) = @{{"pp_anonlist" => ["[","]"], + "pp_anonhash" => ["{","}"]}->{$kid->ppaddr}}; + my($expr, @exprs); + $kid = $kid->first->sibling; # skip pushmark + for (; !null($kid); $kid = $kid->sibling) { + $expr = $self->deparse($kid, 6); + push @exprs, $expr; + } + return $pre . join(", ", @exprs) . $post; + } elsif (!null($kid->sibling) and + $kid->sibling->ppaddr eq "pp_anoncode") { + return "sub " . + $self->deparse_sub($self->padval($kid->sibling->targ)); + } elsif ($kid->ppaddr eq "pp_pushmark" + and $kid->sibling->ppaddr =~ /^pp_(pad|rv2)[ah]v$/ + and not $kid->sibling->flags & OPf_REF) { + # The @a in \(@a) isn't in ref context, but only when the + # parens are there. + return "\\(" . $self->deparse($kid->sibling, 1) . ")"; + } + } + $self->pfixop($op, $cx, "\\", 20); +} + +sub pp_srefgen { pp_refgen(@_) } + +sub pp_readline { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first; + $kid = $kid->first if $kid->ppaddr eq "pp_rv2gv"; # <$fh> + if ($kid->ppaddr eq "pp_rv2gv") { + $kid = $kid->first; + } + return "<" . $self->deparse($kid, 1) . ">"; +} + +sub loopex { + my $self = shift; + my ($op, $cx, $name) = @_; + if (class($op) eq "PVOP") { + return "$name " . $op->pv; + } elsif (class($op) eq "OP") { + return $name; + } elsif (class($op) eq "UNOP") { + # Note -- loop exits are actually exempt from the + # looks-like-a-func rule, but a few extra parens won't hurt + return $self->maybe_parens_unop($name, $op->first, $cx); + } +} + +sub pp_last { loopex(@_, "last") } +sub pp_next { loopex(@_, "next") } +sub pp_redo { loopex(@_, "redo") } +sub pp_goto { loopex(@_, "goto") } +sub pp_dump { loopex(@_, "dump") } + +sub ftst { + my $self = shift; + my($op, $cx, $name) = @_; + if (class($op) eq "UNOP") { + # Genuine `-X' filetests are exempt from the LLAFR, but not + # l?stat(); for the sake of clarity, give'em all parens + return $self->maybe_parens_unop($name, $op->first, $cx); + } elsif (class($op) eq "GVOP") { + return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16); + } else { # I don't think baseop filetests ever survive ck_ftst, but... + return $name; + } +} + +sub pp_lstat { ftst(@_, "lstat") } +sub pp_stat { ftst(@_, "stat") } +sub pp_ftrread { ftst(@_, "-R") } +sub pp_ftrwrite { ftst(@_, "-W") } +sub pp_ftrexec { ftst(@_, "-X") } +sub pp_fteread { ftst(@_, "-r") } +sub pp_ftewrite { ftst(@_, "-r") } +sub pp_fteexec { ftst(@_, "-r") } +sub pp_ftis { ftst(@_, "-e") } +sub pp_fteowned { ftst(@_, "-O") } +sub pp_ftrowned { ftst(@_, "-o") } +sub pp_ftzero { ftst(@_, "-z") } +sub pp_ftsize { ftst(@_, "-s") } +sub pp_ftmtime { ftst(@_, "-M") } +sub pp_ftatime { ftst(@_, "-A") } +sub pp_ftctime { ftst(@_, "-C") } +sub pp_ftsock { ftst(@_, "-S") } +sub pp_ftchr { ftst(@_, "-c") } +sub pp_ftblk { ftst(@_, "-b") } +sub pp_ftfile { ftst(@_, "-f") } +sub pp_ftdir { ftst(@_, "-d") } +sub pp_ftpipe { ftst(@_, "-p") } +sub pp_ftlink { ftst(@_, "-l") } +sub pp_ftsuid { ftst(@_, "-u") } +sub pp_ftsgid { ftst(@_, "-g") } +sub pp_ftsvtx { ftst(@_, "-k") } +sub pp_fttty { ftst(@_, "-t") } +sub pp_fttext { ftst(@_, "-T") } +sub pp_ftbinary { ftst(@_, "-B") } + +sub SWAP_CHILDREN () { 1 } +sub ASSIGN () { 2 } # has OP= variant + +sub OPf_STACKED () { 64 } + +my(%left, %right); + +sub assoc_class { + my $op = shift; + my $name = $op->ppaddr; + if ($name eq "pp_concat" and $op->first->ppaddr eq "pp_concat") { + # avoid spurious `=' -- see comment in pp_concat + return "pp_concat"; + } + if ($name eq "pp_null" and class($op) eq "UNOP" + and $op->first->ppaddr =~ /^pp_(and|x?or)$/ + and null $op->first->sibling) + { + # Like all conditional constructs, OP_ANDs and OP_ORs are topped + # with a null that's used as the common end point of the two + # flows of control. For precedence purposes, ignore it. + # (COND_EXPRs have these too, but we don't bother with + # their associativity). + return assoc_class($op->first); + } + return $name . ($op->flags & OPf_STACKED ? "=" : ""); +} + +# Left associative operators, like `+', for which +# $a + $b + $c is equivalent to ($a + $b) + $c + +BEGIN { + %left = ('pp_multiply' => 19, 'pp_i_multiply' => 19, + 'pp_divide' => 19, 'pp_i_divide' => 19, + 'pp_modulo' => 19, 'pp_i_modulo' => 19, + 'pp_repeat' => 19, + 'pp_add' => 18, 'pp_i_add' => 18, + 'pp_subtract' => 18, 'pp_i_subtract' => 18, + 'pp_concat' => 18, + 'pp_left_shift' => 17, 'pp_right_shift' => 17, + 'pp_bit_and' => 13, + 'pp_bit_or' => 12, 'pp_bit_xor' => 12, + 'pp_and' => 3, + 'pp_or' => 2, 'pp_xor' => 2, + ); +} + +sub deparse_binop_left { + my $self = shift; + my($op, $left, $prec) = @_; + if ($left{assoc_class($op)} + and $left{assoc_class($op)} == $left{assoc_class($left)}) + { + return $self->deparse($left, $prec - .00001); + } else { + return $self->deparse($left, $prec); + } +} + +# Right associative operators, like `=', for which +# $a = $b = $c is equivalent to $a = ($b = $c) + +BEGIN { + %right = ('pp_pow' => 22, + 'pp_sassign=' => 7, 'pp_aassign=' => 7, + 'pp_multiply=' => 7, 'pp_i_multiply=' => 7, + 'pp_divide=' => 7, 'pp_i_divide=' => 7, + 'pp_modulo=' => 7, 'pp_i_modulo=' => 7, + 'pp_repeat=' => 7, + 'pp_add=' => 7, 'pp_i_add=' => 7, + 'pp_subtract=' => 7, 'pp_i_subtract=' => 7, + 'pp_concat=' => 7, + 'pp_left_shift=' => 7, 'pp_right_shift=' => 7, + 'pp_bit_and=' => 7, + 'pp_bit_or=' => 7, 'pp_bit_xor=' => 7, + 'pp_andassign' => 7, + 'pp_orassign' => 7, + ); +} + +sub deparse_binop_right { + my $self = shift; + my($op, $right, $prec) = @_; + if ($right{assoc_class($op)} + and $right{assoc_class($op)} == $right{assoc_class($right)}) + { + return $self->deparse($right, $prec - .00001); + } else { + return $self->deparse($right, $prec); + } +} + +sub binop { + my $self = shift; + my ($op, $cx, $opname, $prec, $flags) = (@_, 0); + my $left = $op->first; + my $right = $op->last; + my $eq = ""; + if ($op->flags & OPf_STACKED && $flags & ASSIGN) { + $eq = "="; + $prec = 7; + } + if ($flags & SWAP_CHILDREN) { + ($left, $right) = ($right, $left); + } + $left = $self->deparse_binop_left($op, $left, $prec); + $right = $self->deparse_binop_right($op, $right, $prec); + return $self->maybe_parens("$left $opname$eq $right", $cx, $prec); +} + +sub pp_add { binop(@_, "+", 18, ASSIGN) } +sub pp_multiply { binop(@_, "*", 19, ASSIGN) } +sub pp_subtract { binop(@_, "-",18, ASSIGN) } +sub pp_divide { binop(@_, "/", 19, ASSIGN) } +sub pp_modulo { binop(@_, "%", 19, ASSIGN) } +sub pp_i_add { binop(@_, "+", 18, ASSIGN) } +sub pp_i_multiply { binop(@_, "*", 19, ASSIGN) } +sub pp_i_subtract { binop(@_, "-", 18, ASSIGN) } +sub pp_i_divide { binop(@_, "/", 19, ASSIGN) } +sub pp_i_modulo { binop(@_, "%", 19, ASSIGN) } +sub pp_pow { binop(@_, "**", 22, ASSIGN) } + +sub pp_left_shift { binop(@_, "<<", 17, ASSIGN) } +sub pp_right_shift { binop(@_, ">>", 17, ASSIGN) } +sub pp_bit_and { binop(@_, "&", 13, ASSIGN) } +sub pp_bit_or { binop(@_, "|", 12, ASSIGN) } +sub pp_bit_xor { binop(@_, "^", 12, ASSIGN) } + +sub pp_eq { binop(@_, "==", 14) } +sub pp_ne { binop(@_, "!=", 14) } +sub pp_lt { binop(@_, "<", 15) } +sub pp_gt { binop(@_, ">", 15) } +sub pp_ge { binop(@_, ">=", 15) } +sub pp_le { binop(@_, "<=", 15) } +sub pp_ncmp { binop(@_, "<=>", 14) } +sub pp_i_eq { binop(@_, "==", 14) } +sub pp_i_ne { binop(@_, "!=", 14) } +sub pp_i_lt { binop(@_, "<", 15) } +sub pp_i_gt { binop(@_, ">", 15) } +sub pp_i_ge { binop(@_, ">=", 15) } +sub pp_i_le { binop(@_, "<=", 15) } +sub pp_i_ncmp { binop(@_, "<=>", 14) } + +sub pp_seq { binop(@_, "eq", 14) } +sub pp_sne { binop(@_, "ne", 14) } +sub pp_slt { binop(@_, "lt", 15) } +sub pp_sgt { binop(@_, "gt", 15) } +sub pp_sge { binop(@_, "ge", 15) } +sub pp_sle { binop(@_, "le", 15) } +sub pp_scmp { binop(@_, "cmp", 14) } + +sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) } +sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) } + +# `.' is special because concats-of-concats are optimized to save copying +# by making all but the first concat stacked. The effect is as if the +# programmer had written `($a . $b) .= $c', except legal. +sub pp_concat { + my $self = shift; + my($op, $cx) = @_; + my $left = $op->first; + my $right = $op->last; + my $eq = ""; + my $prec = 18; + if ($op->flags & OPf_STACKED and $op->first->ppaddr ne "pp_concat") { + $eq = "="; + $prec = 7; + } + $left = $self->deparse_binop_left($op, $left, $prec); + $right = $self->deparse_binop_right($op, $right, $prec); + return $self->maybe_parens("$left .$eq $right", $cx, $prec); +} + +# `x' is weird when the left arg is a list +sub pp_repeat { + my $self = shift; + my($op, $cx) = @_; + my $left = $op->first; + my $right = $op->last; + my $eq = ""; + my $prec = 19; + if ($op->flags & OPf_STACKED) { + $eq = "="; + $prec = 7; + } + if (null($right)) { # list repeat; count is inside left-side ex-list + my $kid = $left->first->sibling; # skip pushmark + my @exprs; + for (; !null($kid->sibling); $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, 6); + } + $right = $kid; + $left = "(" . join(", ", @exprs). ")"; + } else { + $left = $self->deparse_binop_left($op, $left, $prec); + } + $right = $self->deparse_binop_right($op, $right, $prec); + return $self->maybe_parens("$left x$eq $right", $cx, $prec); +} + +sub range { + my $self = shift; + my ($op, $cx, $type) = @_; + my $left = $op->first; + my $right = $left->sibling; + $left = $self->deparse($left, 9); + $right = $self->deparse($right, 9); + return $self->maybe_parens("$left $type $right", $cx, 9); +} + +sub pp_flop { + my $self = shift; + my($op, $cx) = @_; + my $flip = $op->first; + my $type = ($flip->flags & OPf_SPECIAL) ? "..." : ".."; + return $self->range($flip->first, $cx, $type); +} + +# one-line while/until is handled in pp_leave + +sub logop { + my $self = shift; + my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_; + my $left = $op->first; + my $right = $op->first->sibling; + if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b} + $left = $self->deparse($left, 1); + $right = $self->deparse($right, 0); + return "$blockname ($left) {\n\t$right\n\b}\cK"; + } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a + $right = $self->deparse($right, 1); + $left = $self->deparse($left, 1); + return "$right $blockname $left"; + } elsif ($cx > $lowprec and $highop) { # $a && $b + $left = $self->deparse_binop_left($op, $left, $highprec); + $right = $self->deparse_binop_right($op, $right, $highprec); + return $self->maybe_parens("$left $highop $right", $cx, $highprec); + } else { # $a and $b + $left = $self->deparse_binop_left($op, $left, $lowprec); + $right = $self->deparse_binop_right($op, $right, $lowprec); + return $self->maybe_parens("$left $lowop $right", $cx, $lowprec); + } +} + +sub pp_and { logop(@_, "and", 3, "&&", 11, "if") } +sub pp_or { logop(@_, "or", 2, "||", 10, "unless") } +sub pp_xor { logop(@_, "xor", 2, "", 0, "") } + +sub logassignop { + my $self = shift; + my ($op, $cx, $opname) = @_; + my $left = $op->first; + my $right = $op->first->sibling->first; # skip sassign + $left = $self->deparse($left, 7); + $right = $self->deparse($right, 7); + return $self->maybe_parens("$left $opname $right", $cx, 7); +} + +sub pp_andassign { logassignop(@_, "&&=") } +sub pp_orassign { logassignop(@_, "||=") } + +sub listop { + my $self = shift; + my($op, $cx, $name) = @_; + my(@exprs); + my $parens = ($cx >= 5) || $self->{'parens'}; + my $kid = $op->first->sibling; + return $name if null $kid; + my $first = $self->deparse($kid, 6); + $first = "+$first" if not $parens and substr($first, 0, 1) eq "("; + push @exprs, $first; + $kid = $kid->sibling; + for (; !null($kid); $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, 6); + } + if ($parens) { + return "$name(" . join(", ", @exprs) . ")"; + } else { + return "$name " . join(", ", @exprs); + } +} + +sub pp_bless { listop(@_, "bless") } +sub pp_atan2 { listop(@_, "atan2") } +sub pp_substr { maybe_local(@_, listop(@_, "substr")) } +sub pp_vec { maybe_local(@_, listop(@_, "vec")) } +sub pp_index { listop(@_, "index") } +sub pp_rindex { listop(@_, "rindex") } +sub pp_sprintf { listop(@_, "sprintf") } +sub pp_formline { listop(@_, "formline") } # see also deparse_format +sub pp_crypt { listop(@_, "crypt") } +sub pp_unpack { listop(@_, "unpack") } +sub pp_pack { listop(@_, "pack") } +sub pp_join { listop(@_, "join") } +sub pp_splice { listop(@_, "splice") } +sub pp_push { listop(@_, "push") } +sub pp_unshift { listop(@_, "unshift") } +sub pp_reverse { listop(@_, "reverse") } +sub pp_warn { listop(@_, "warn") } +sub pp_die { listop(@_, "die") } +# Actually, return is exempt from the LLAFR (see examples in this very +# module!), but for consistency's sake, ignore that fact +sub pp_return { listop(@_, "return") } +sub pp_open { listop(@_, "open") } +sub pp_pipe_op { listop(@_, "pipe") } +sub pp_tie { listop(@_, "tie") } +sub pp_dbmopen { listop(@_, "dbmopen") } +sub pp_sselect { listop(@_, "select") } +sub pp_select { listop(@_, "select") } +sub pp_read { listop(@_, "read") } +sub pp_sysopen { listop(@_, "sysopen") } +sub pp_sysseek { listop(@_, "sysseek") } +sub pp_sysread { listop(@_, "sysread") } +sub pp_syswrite { listop(@_, "syswrite") } +sub pp_send { listop(@_, "send") } +sub pp_recv { listop(@_, "recv") } +sub pp_seek { listop(@_, "seek") } +sub pp_fcntl { listop(@_, "fcntl") } +sub pp_ioctl { listop(@_, "ioctl") } +sub pp_flock { listop(@_, "flock") } +sub pp_socket { listop(@_, "socket") } +sub pp_sockpair { listop(@_, "sockpair") } +sub pp_bind { listop(@_, "bind") } +sub pp_connect { listop(@_, "connect") } +sub pp_listen { listop(@_, "listen") } +sub pp_accept { listop(@_, "accept") } +sub pp_shutdown { listop(@_, "shutdown") } +sub pp_gsockopt { listop(@_, "getsockopt") } +sub pp_ssockopt { listop(@_, "setsockopt") } +sub pp_chown { listop(@_, "chown") } +sub pp_unlink { listop(@_, "unlink") } +sub pp_chmod { listop(@_, "chmod") } +sub pp_utime { listop(@_, "utime") } +sub pp_rename { listop(@_, "rename") } +sub pp_link { listop(@_, "link") } +sub pp_symlink { listop(@_, "symlink") } +sub pp_mkdir { listop(@_, "mkdir") } +sub pp_open_dir { listop(@_, "opendir") } +sub pp_seekdir { listop(@_, "seekdir") } +sub pp_waitpid { listop(@_, "waitpid") } +sub pp_system { listop(@_, "system") } +sub pp_exec { listop(@_, "exec") } +sub pp_kill { listop(@_, "kill") } +sub pp_setpgrp { listop(@_, "setpgrp") } +sub pp_getpriority { listop(@_, "getpriority") } +sub pp_setpriority { listop(@_, "setpriority") } +sub pp_shmget { listop(@_, "shmget") } +sub pp_shmctl { listop(@_, "shmctl") } +sub pp_shmread { listop(@_, "shmread") } +sub pp_shmwrite { listop(@_, "shmwrite") } +sub pp_msgget { listop(@_, "msgget") } +sub pp_msgctl { listop(@_, "msgctl") } +sub pp_msgsnd { listop(@_, "msgsnd") } +sub pp_msgrcv { listop(@_, "msgrcv") } +sub pp_semget { listop(@_, "semget") } +sub pp_semctl { listop(@_, "semctl") } +sub pp_semop { listop(@_, "semop") } +sub pp_ghbyaddr { listop(@_, "gethostbyaddr") } +sub pp_gnbyaddr { listop(@_, "getnetbyaddr") } +sub pp_gpbynumber { listop(@_, "getprotobynumber") } +sub pp_gsbyname { listop(@_, "getservbyname") } +sub pp_gsbyport { listop(@_, "getservbyport") } +sub pp_syscall { listop(@_, "syscall") } + +sub pp_glob { + my $self = shift; + my($op, $cx) = @_; + my $text = $self->dq($op->first->sibling); # skip pushmark + if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline + or $text =~ /[<>]/) { + return 'glob(' . single_delim('qq', '"', $text) . ')'; + } else { + return '<' . $text . '>'; + } +} + +# Truncate is special because OPf_SPECIAL makes a bareword first arg +# be a filehandle. This could probably be better fixed in the core +# by moving the GV lookup into ck_truc. + +sub pp_truncate { + my $self = shift; + my($op, $cx) = @_; + my(@exprs); + my $parens = ($cx >= 5) || $self->{'parens'}; + my $kid = $op->first->sibling; + my($fh, $len); + if ($op->flags & OPf_SPECIAL) { + # $kid is an OP_CONST + $fh = $kid->sv->PV; + } else { + $fh = $self->deparse($kid, 6); + $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "("; + } + my $len = $self->deparse($kid->sibling, 6); + if ($parens) { + return "truncate($fh, $len)"; + } else { + return "truncate $fh, $len"; + } + +} + +sub indirop { + my $self = shift; + my($op, $cx, $name) = @_; + my($expr, @exprs); + my $kid = $op->first->sibling; + my $indir = ""; + if ($op->flags & OPf_STACKED) { + $indir = $kid; + $indir = $indir->first; # skip rv2gv + if (is_scope($indir)) { + $indir = "{" . $self->deparse($indir, 0) . "}"; + } else { + $indir = $self->deparse($indir, 24); + } + $indir = $indir . " "; + $kid = $kid->sibling; + } + for (; !null($kid); $kid = $kid->sibling) { + $expr = $self->deparse($kid, 6); + push @exprs, $expr; + } + return $self->maybe_parens_func($name, + $indir . join(", ", @exprs), + $cx, 5); +} + +sub pp_prtf { indirop(@_, "printf") } +sub pp_print { indirop(@_, "print") } +sub pp_sort { indirop(@_, "sort") } + +sub mapop { + my $self = shift; + my($op, $cx, $name) = @_; + my($expr, @exprs); + my $kid = $op->first; # this is the (map|grep)start + $kid = $kid->first->sibling; # skip a pushmark + my $code = $kid->first; # skip a null + if (is_scope $code) { + $code = "{" . $self->deparse($code, 1) . "} "; + } else { + $code = $self->deparse($code, 24) . ", "; + } + $kid = $kid->sibling; + for (; !null($kid); $kid = $kid->sibling) { + $expr = $self->deparse($kid, 6); + push @exprs, $expr if $expr; + } + return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5); +} + +sub pp_mapwhile { mapop(@_, "map") } +sub pp_grepwhile { mapop(@_, "grep") } + +sub pp_list { + my $self = shift; + my($op, $cx) = @_; + my($expr, @exprs); + my $kid = $op->first->sibling; # skip pushmark + my $lop; + my $local = "either"; # could be local(...) or my(...) + for ($lop = $kid; !null($lop); $lop = $lop->sibling) { + # This assumes that no other private flags equal 128, and that + # OPs that store things other than flags in their op_private, + # like OP_AELEMFAST, won't be immediate children of a list. + unless ($lop->private & OPp_LVAL_INTRO or $lop->ppaddr eq "pp_undef") + { + $local = ""; # or not + last; + } + if ($lop->ppaddr =~ /^pp_pad[ash]v$/) { # my() + ($local = "", last) if $local eq "local"; + $local = "my"; + } elsif ($lop->ppaddr ne "pp_undef") { # local() + ($local = "", last) if $local eq "my"; + $local = "local"; + } + } + $local = "" if $local eq "either"; # no point if it's all undefs + return $self->deparse($kid, $cx) if null $kid->sibling and not $local; + for (; !null($kid); $kid = $kid->sibling) { + if ($local) { + if (class($kid) eq "UNOP" and $kid->first->ppaddr eq "pp_gvsv") { + $lop = $kid->first; + } else { + $lop = $kid; + } + $self->{'avoid_local'}{$$lop}++; + $expr = $self->deparse($kid, 6); + delete $self->{'avoid_local'}{$$lop}; + } else { + $expr = $self->deparse($kid, 6); + } + push @exprs, $expr; + } + if ($local) { + return "$local(" . join(", ", @exprs) . ")"; + } else { + return $self->maybe_parens( join(", ", @exprs), $cx, 6); + } +} + +sub pp_cond_expr { + my $self = shift; + my($op, $cx) = @_; + my $cond = $op->first; + my $true = $cond->sibling; + my $false = $true->sibling; + my $cuddle = $self->{'cuddle'}; + unless ($cx == 0 and is_scope($true) and is_scope($false)) { + $cond = $self->deparse($cond, 8); + $true = $self->deparse($true, 8); + $false = $self->deparse($false, 8); + return $self->maybe_parens("$cond ? $true : $false", $cx, 8); + } + $cond = $self->deparse($cond, 1); + $true = $self->deparse($true, 0); + if ($false->ppaddr eq "pp_lineseq") { # braces w/o scope => elsif + my $head = "if ($cond) {\n\t$true\n\b}"; + my @elsifs; + while (!null($false) and $false->ppaddr eq "pp_lineseq") { + my $newop = $false->first->sibling->first; + my $newcond = $newop->first; + my $newtrue = $newcond->sibling; + $false = $newtrue->sibling; # last in chain is OP_AND => no else + $newcond = $self->deparse($newcond, 1); + $newtrue = $self->deparse($newtrue, 0); + push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}"; + } + if (!null($false)) { + $false = $cuddle . "else {\n\t" . + $self->deparse($false, 0) . "\n\b}\cK"; + } else { + $false = "\cK"; + } + return $head . join($cuddle, "", @elsifs) . $false; + } + $false = $self->deparse($false, 0); + return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK"; +} + +sub pp_leaveloop { + my $self = shift; + my($op, $cx) = @_; + my $enter = $op->first; + my $kid = $enter->sibling; + local($self->{'curstash'}) = $self->{'curstash'}; + my $head = ""; + my $bare = 0; + if ($kid->ppaddr eq "pp_lineseq") { # bare or infinite loop + if (is_state $kid->last) { # infinite + $head = "for (;;) "; # shorter than while (1) + } else { + $bare = 1; + } + } elsif ($enter->ppaddr eq "pp_enteriter") { # foreach + my $ary = $enter->first->sibling; # first was pushmark + my $var = $ary->sibling; + if ($enter->flags & OPf_STACKED + and not null $ary->first->sibling->sibling) + { + $ary = $self->deparse($ary->first->sibling, 9) . " .. " . + $self->deparse($ary->first->sibling->sibling, 9); + } else { + $ary = $self->deparse($ary, 1); + } + if (null $var) { + if ($enter->flags & OPf_SPECIAL) { # thread special var + $var = $self->pp_threadsv($enter, 1); + } else { # regular my() variable + $var = $self->pp_padsv($enter, 1); + if ($self->padname_sv($enter->targ)->IVX == + $kid->first->first->sibling->last->cop_seq) + { + # If the scope of this variable closes at the last + # statement of the loop, it must have been + # declared here. + $var = "my " . $var; + } + } + } elsif ($var->ppaddr eq "pp_rv2gv") { + $var = $self->pp_rv2sv($var, 1); + } elsif ($var->ppaddr eq "pp_gv") { + $var = "\$" . $self->deparse($var, 1); + } + $head = "foreach $var ($ary) "; + $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER + } elsif ($kid->ppaddr eq "pp_null") { # while/until + $kid = $kid->first; + my $name = {"pp_and" => "while", "pp_or" => "until"} + ->{$kid->ppaddr}; + $head = "$name (" . $self->deparse($kid->first, 1) . ") "; + $kid = $kid->first->sibling; + } elsif ($kid->ppaddr eq "pp_stub") { # bare and empty + return "{;}"; # {} could be a hashref + } + # The third-to-last kid is the continue block if the pointer used + # by `next BLOCK' points to its first OP, which happens to be the + # the op_next of the head of the _previous_ statement. + # Unless it's a bare loop, in which case it's last, since there's + # no unstack or extra nextstate. + # Except if the previous head isn't null but the first kid is + # (because it's a nulled out nextstate in a scope), in which + # case the head's next is advanced past the null but the nextop's + # isn't, so we need to try nextop->next. + my($cont, $precont); + if ($bare) { + $cont = $kid->first; + while (!null($cont->sibling)) { + $precont = $cont; + $cont = $cont->sibling; + } + } else { + $cont = $kid->first; + while (!null($cont->sibling->sibling->sibling)) { + $precont = $cont; + $cont = $cont->sibling; + } + } + if ($precont and $ {$precont->next} == $ {$enter->nextop} + || $ {$precont->next} == $ {$enter->nextop->next} ) + { + my $state = $kid->first; + my $cuddle = $self->{'cuddle'}; + my($expr, @exprs); + for (; $$state != $$cont; $state = $state->sibling) { + $expr = ""; + if (is_state $state) { + $expr = $self->deparse($state, 0); + $state = $state->sibling; + last if null $kid; + } + $expr .= $self->deparse($state, 0); + push @exprs, $expr if $expr; + } + $kid = join(";\n", @exprs); + $cont = $cuddle . "continue {\n\t" . + $self->deparse($cont, 0) . "\n\b}\cK"; + } else { + $cont = "\cK"; + $kid = $self->deparse($kid, 0); + } + return $head . "{\n\t" . $kid . "\n\b}" . $cont; +} + +sub pp_leavetry { + my $self = shift; + return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}"; +} + +sub OP_CONST () { 5 } + +# XXX need a better way to do this +sub OP_STRINGIFY () { $] > 5.004_72 ? 67 : 65 } + +sub pp_null { + my $self = shift; + my($op, $cx) = @_; + if (class($op) eq "OP") { + return "'???'" if $op->targ == OP_CONST; # old value is lost + } elsif ($op->first->ppaddr eq "pp_pushmark") { + return $self->pp_list($op, $cx); + } elsif ($op->first->ppaddr eq "pp_enter") { + return $self->pp_leave($op, $cx); + } elsif ($op->targ == OP_STRINGIFY) { + return $self->dquote($op); + } elsif (!null($op->first->sibling) and + $op->first->sibling->ppaddr eq "pp_readline" and + $op->first->sibling->flags & OPf_STACKED) { + return $self->maybe_parens($self->deparse($op->first, 7) . " = " + . $self->deparse($op->first->sibling, 7), + $cx, 7); + } elsif (!null($op->first->sibling) and + $op->first->sibling->ppaddr eq "pp_trans" and + $op->first->sibling->flags & OPf_STACKED) { + return $self->maybe_parens($self->deparse($op->first, 20) . " =~ " + . $self->deparse($op->first->sibling, 20), + $cx, 20); + } else { + return $self->deparse($op->first, $cx); + } +} + +sub padname { + my $self = shift; + my $targ = shift; + my $str = $self->padname_sv($targ)->PV; + return padname_fix($str); +} + +sub padany { + my $self = shift; + my $op = shift; + return substr($self->padname($op->targ), 1); # skip $/@/% +} + +sub pp_padsv { + my $self = shift; + my($op, $cx) = @_; + return $self->maybe_my($op, $cx, $self->padname($op->targ)); +} + +sub pp_padav { pp_padsv(@_) } +sub pp_padhv { pp_padsv(@_) } + +my @threadsv_names; + +BEGIN { + @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9", + "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";", + "^", "-", "%", "=", "|", "~", ":", "^A", "^E", + "!", "@"); +} + +sub pp_threadsv { + my $self = shift; + my($op, $cx) = @_; + return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]); +} + +sub pp_gvsv { + my $self = shift; + my($op, $cx) = @_; + return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv)); +} + +sub pp_gv { + my $self = shift; + my($op, $cx) = @_; + return $self->gv_name($op->gv); +} + +sub pp_aelemfast { + my $self = shift; + my($op, $cx) = @_; + my $gv = $op->gv; + return "\$" . $self->gv_name($gv) . "[" . $op->private . "]"; +} + +sub rv2x { + my $self = shift; + my($op, $cx, $type) = @_; + my $kid = $op->first; + my $str = $self->deparse($kid, 0); + return $type . (is_scalar($kid) ? $str : "{$str}"); +} + +sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) } +sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) } +sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) } + +# skip rv2av +sub pp_av2arylen { + my $self = shift; + my($op, $cx) = @_; + if ($op->first->ppaddr eq "pp_padav") { + return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first)); + } else { + return $self->maybe_local($op, $cx, + $self->rv2x($op->first, $cx, '$#')); + } +} + +# skip down to the old, ex-rv2cv +sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") } + +sub pp_rv2av { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first; + if ($kid->ppaddr eq "pp_const") { # constant list + my $av = $kid->sv; + return "(" . join(", ", map(const($_), $av->ARRAY)) . ")"; + } else { + return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@")); + } + } + + +sub elem { + my $self = shift; + my ($op, $cx, $left, $right, $padname) = @_; + my($array, $idx) = ($op->first, $op->first->sibling); + unless ($array->ppaddr eq $padname) { # Maybe this has been fixed + $array = $array->first; # skip rv2av (or ex-rv2av in _53+) + } + if ($array->ppaddr eq $padname) { + $array = $self->padany($array); + } elsif (is_scope($array)) { # ${expr}[0] + $array = "{" . $self->deparse($array, 0) . "}"; + } elsif (is_scalar $array) { # $x[0], $$x[0], ... + $array = $self->deparse($array, 24); + } else { + # $x[20][3]{hi} or expr->[20] + my $arrow; + $arrow = "->" if $array->ppaddr !~ /^pp_[ah]elem$/; + return $self->deparse($array, 24) . $arrow . + $left . $self->deparse($idx, 1) . $right; + } + $idx = $self->deparse($idx, 1); + return "\$" . $array . $left . $idx . $right; +} + +sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "pp_padav")) } +sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "pp_padhv")) } + +sub pp_gelem { + my $self = shift; + my($op, $cx) = @_; + my($glob, $part) = ($op->first, $op->last); + $glob = $glob->first; # skip rv2gv + $glob = $glob->first if $glob->ppaddr eq "pp_rv2gv"; # this one's a bug + my $scope = is_scope($glob); + $glob = $self->deparse($glob, 0); + $part = $self->deparse($part, 1); + return "*" . ($scope ? "{$glob}" : $glob) . "{$part}"; +} + +sub slice { + my $self = shift; + my ($op, $cx, $left, $right, $regname, $padname) = @_; + my $last; + my(@elems, $kid, $array, $list); + if (class($op) eq "LISTOP") { + $last = $op->last; + } else { # ex-hslice inside delete() + for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {} + $last = $kid; + } + $array = $last; + $array = $array->first + if $array->ppaddr eq $regname or $array->ppaddr eq "pp_null"; + if (is_scope($array)) { + $array = "{" . $self->deparse($array, 0) . "}"; + } elsif ($array->ppaddr eq $padname) { + $array = $self->padany($array); + } else { + $array = $self->deparse($array, 24); + } + $kid = $op->first->sibling; # skip pushmark + if ($kid->ppaddr eq "pp_list") { + $kid = $kid->first->sibling; # skip list, pushmark + for (; !null $kid; $kid = $kid->sibling) { + push @elems, $self->deparse($kid, 6); + } + $list = join(", ", @elems); + } else { + $list = $self->deparse($kid, 1); + } + return "\@" . $array . $left . $list . $right; +} + +sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", + "pp_rv2av", "pp_padav")) } +sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", + "pp_rv2hv", "pp_padhv")) } + +sub pp_lslice { + my $self = shift; + my($op, $cx) = @_; + my $idx = $op->first; + my $list = $op->last; + my(@elems, $kid); + $list = $self->deparse($list, 1); + $idx = $self->deparse($idx, 1); + return "($list)" . "[$idx]"; +} + +sub OPpENTERSUB_AMPER () { 8 } + +sub OPf_WANT () { 3 } +sub OPf_WANT_VOID () { 1 } +sub OPf_WANT_SCALAR () { 2 } +sub OPf_WANT_LIST () { 2 } + +sub want_scalar { + my $op = shift; + return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR; +} + +sub pp_entersub { + my $self = shift; + my($op, $cx) = @_; + my $prefix = ""; + my $amper = ""; + my $proto = undef; + my $simple = 0; + my($kid, $args, @exprs); + if (not null $op->first->sibling) { # method + $kid = $op->first->sibling; # skip pushmark + my $obj = $self->deparse($kid, 24); + $kid = $kid->sibling; + for (; not null $kid->sibling; $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, 6); + } + my $meth = $kid->first; + if ($meth->ppaddr eq "pp_const") { + $meth = $meth->sv->PV; # needs to be bare + } else { + $meth = $self->deparse($meth, 1); + } + $args = join(", ", @exprs); + $kid = $obj . "->" . $meth; + if ($args) { + return $kid . "(" . $args . ")"; # parens mandatory + } else { + return $kid; # toke.c fakes parens + } + } + # else, not a method + if ($op->flags & OPf_SPECIAL) { + $prefix = "do "; + } elsif ($op->private & OPpENTERSUB_AMPER) { + $amper = "&"; + } + $kid = $op->first; + $kid = $kid->first->sibling; # skip ex-list, pushmark + for (; not null $kid->sibling; $kid = $kid->sibling) { + push @exprs, $kid; + } + if (is_scope($kid)) { + $amper = "&"; + $kid = "{" . $self->deparse($kid, 0) . "}"; + } elsif ($kid->first->ppaddr eq "pp_gv") { + my $gv = $kid->first->gv; + if (class($gv->CV) ne "SPECIAL") { + $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK; + } + $simple = 1; + $kid = $self->deparse($kid, 24); + } elsif (is_scalar $kid->first) { + $amper = "&"; + $kid = $self->deparse($kid, 24); + } else { + $prefix = ""; + $kid = $self->deparse($kid, 24) . "->"; + } + if (defined $proto and not $amper) { + my($arg, $real); + my $doneok = 0; + my @args = @exprs; + my @reals; + my $p = $proto; + $p =~ s/([^\\]|^)([@%])(.*)$/$1$2/; + while ($p) { + $p =~ s/^ *([\\]?[\$\@&%*]|;)//; + my $chr = $1; + if ($chr eq "") { + undef $proto if @args; + } elsif ($chr eq ";") { + $doneok = 1; + } elsif ($chr eq "@" or $chr eq "%") { + push @reals, map($self->deparse($_, 6), @args); + @args = (); + } else { + $arg = shift @args; + last unless $arg; + if ($chr eq "\$") { + if (want_scalar $arg) { + push @reals, $self->deparse($arg, 6); + } else { + undef $proto; + } + } elsif ($chr eq "&") { + if ($arg->ppaddr =~ /pp_(s?refgen|undef)/) { + push @reals, $self->deparse($arg, 6); + } else { + undef $proto; + } + } elsif ($chr eq "*") { + if ($arg->ppaddr =~ /^pp_s?refgen$/ + and $arg->first->first->ppaddr eq "pp_rv2gv") + { + $real = $arg->first->first; # skip refgen, null + if ($real->first->ppaddr eq "pp_gv") { + push @reals, $self->deparse($real, 6); + } else { + push @reals, $self->deparse($real->first, 6); + } + } else { + undef $proto; + } + } elsif (substr($chr, 0, 1) eq "\\") { + $chr = substr($chr, 1); + if ($arg->ppaddr =~ /^pp_s?refgen$/ and + !null($real = $arg->first) and + ($chr eq "\$" && is_scalar($real->first) + or ($chr eq "\@" + && $real->first->sibling->ppaddr + =~ /^pp_(rv2|pad)av$/) + or ($chr eq "%" + && $real->first->sibling->ppaddr + =~ /^pp_(rv2|pad)hv$/) + #or ($chr eq "&" # This doesn't work + # && $real->first->ppaddr eq "pp_rv2cv") + or ($chr eq "*" + && $real->first->ppaddr eq "pp_rv2gv"))) + { + push @reals, $self->deparse($real, 6); + } else { + undef $proto; + } + } + } + } + undef $proto if $p and !$doneok; + undef $proto if @args; + $args = join(", ", @reals); + $amper = ""; + unless (defined $proto) { + $amper = "&"; + $args = join(", ", map($self->deparse($_, 6), @exprs)); + } + } else { + $args = join(", ", map($self->deparse($_, 6), @exprs)); + } + if ($prefix or $amper) { + if ($op->flags & OPf_STACKED) { + return $prefix . $amper . $kid . "(" . $args . ")"; + } else { + return $prefix . $amper. $kid; + } + } else { + if (defined $proto and $proto eq "") { + return $kid; + } elsif ($proto eq "\$") { + return $self->maybe_parens_func($kid, $args, $cx, 16); + } elsif ($proto or $simple) { + return $self->maybe_parens_func($kid, $args, $cx, 5); + } else { + return "$kid(" . $args . ")"; + } + } +} + +sub pp_enterwrite { unop(@_, "write") } + +# escape things that cause interpolation in double quotes, +# but not character escapes +sub uninterp { + my($str) = @_; + $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g; + return $str; +} + +# the same, but treat $|, $), and $ at the end of the string differently +sub re_uninterp { + my($str) = @_; + $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g; + $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g; + return $str; +} + +# character escapes, but not delimiters that might need to be escaped +sub escape_str { # ASCII + my($str) = @_; + $str =~ s/\a/\\a/g; +# $str =~ s/\cH/\\b/g; # \b means someting different in a regex + $str =~ s/\t/\\t/g; + $str =~ s/\n/\\n/g; + $str =~ s/\e/\\e/g; + $str =~ s/\f/\\f/g; + $str =~ s/\r/\\r/g; + $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge; + $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge; + return $str; +} + +# Don't do this for regexen +sub unback { + my($str) = @_; + $str =~ s/\\/\\\\/g; + return $str; +} + +sub balanced_delim { + my($str) = @_; + my @str = split //, $str; + my($ar, $open, $close, $fail, $c, $cnt); + for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) { + ($open, $close) = @$ar; + $fail = 0; $cnt = 0; + for $c (@str) { + if ($c eq $open) { + $cnt++; + } elsif ($c eq $close) { + $cnt--; + if ($cnt < 0) { + $fail = 1; + last; + } + } + } + $fail = 1 if $cnt != 0; + return ($open, "$open$str$close") if not $fail; + } + return ("", $str); +} + +sub single_delim { + my($q, $default, $str) = @_; + return "$default$str$default" if $default and index($str, $default) == -1; + my($succeed, $delim); + ($succeed, $str) = balanced_delim($str); + return "$q$str" if $succeed; + for $delim ('/', '"', '#') { + return "$q$delim" . $str . $delim if index($str, $delim) == -1; + } + if ($default) { + $str =~ s/$default/\\$default/g; + return "$default$str$default"; + } else { + $str =~ s[/][\\/]g; + return "$q/$str/"; + } +} + +sub SVf_IOK () {0x10000} +sub SVf_NOK () {0x20000} +sub SVf_ROK () {0x80000} + +sub const { + my $sv = shift; + if (class($sv) eq "SPECIAL") { + return ('undef', '1', '0')[$$sv-1]; + } elsif ($sv->FLAGS & SVf_IOK) { + return $sv->IV; + } elsif ($sv->FLAGS & SVf_NOK) { + return $sv->NV; + } elsif ($sv->FLAGS & SVf_ROK) { + return "\\(" . const($sv->RV) . ")"; # constant folded + } else { + my $str = $sv->PV; + if ($str =~ /[^ -~]/) { # ASCII + return single_delim("qq", '"', uninterp escape_str unback $str); + } else { + $str =~ s/\\/\\\\/g; + return single_delim("q", "'", $str); + } + } +} + +sub pp_const { + my $self = shift; + my($op, $cx) = @_; +# if ($op->private & OPp_CONST_BARE) { # trouble with `=>' autoquoting +# return $op->sv->PV; +# } + return const($op->sv); +} + +sub dq { + my $self = shift; + my $op = shift; + my $type = $op->ppaddr; + if ($type eq "pp_const") { + return uninterp(escape_str(unback($op->sv->PV))); + } elsif ($type eq "pp_concat") { + return $self->dq($op->first) . $self->dq($op->last); + } elsif ($type eq "pp_uc") { + return '\U' . $self->dq($op->first->sibling) . '\E'; + } elsif ($type eq "pp_lc") { + return '\L' . $self->dq($op->first->sibling) . '\E'; + } elsif ($type eq "pp_ucfirst") { + return '\u' . $self->dq($op->first->sibling); + } elsif ($type eq "pp_lcfirst") { + return '\l' . $self->dq($op->first->sibling); + } elsif ($type eq "pp_quotemeta") { + return '\Q' . $self->dq($op->first->sibling) . '\E'; + } elsif ($type eq "pp_join") { + return $self->deparse($op->last, 26); # was join($", @ary) + } else { + return $self->deparse($op, 26); + } +} + +sub pp_backtick { + my $self = shift; + my($op, $cx) = @_; + # skip pushmark + return single_delim("qx", '`', $self->dq($op->first->sibling)); +} + +sub dquote { + my $self = shift; + my $op = shift; + # skip ex-stringify, pushmark + return single_delim("qq", '"', $self->dq($op->first->sibling)); +} + +# OP_STRINGIFY is a listop, but it only ever has one arg (?) +sub pp_stringify { dquote(@_) } + +# tr/// and s/// (and tr[][], tr[]//, tr###, etc) +# note that tr(from)/to/ is OK, but not tr/from/(to) +sub double_delim { + my($from, $to) = @_; + my($succeed, $delim); + if ($from !~ m[/] and $to !~ m[/]) { + return "/$from/$to/"; + } elsif (($succeed, $from) = balanced_delim($from) and $succeed) { + if (($succeed, $to) = balanced_delim($to) and $succeed) { + return "$from$to"; + } else { + for $delim ('/', '"', '#') { # note no `'' -- s''' is special + return "$from$delim$to$delim" if index($to, $delim) == -1; + } + $to =~ s[/][\\/]g; + return "$from/$to/"; + } + } else { + for $delim ('/', '"', '#') { # note no ' + return "$delim$from$delim$to$delim" + if index($to . $from, $delim) == -1; + } + $from =~ s[/][\\/]g; + $to =~ s[/][\\/]g; + return "/$from/$to/"; + } +} + +sub pchr { # ASCII + my($n) = @_; + if ($n == ord '\\') { + return '\\\\'; + } elsif ($n >= ord(' ') and $n <= ord('~')) { + return chr($n); + } elsif ($n == ord "\a") { + return '\\a'; + } elsif ($n == ord "\b") { + return '\\b'; + } elsif ($n == ord "\t") { + return '\\t'; + } elsif ($n == ord "\n") { + return '\\n'; + } elsif ($n == ord "\e") { + return '\\e'; + } elsif ($n == ord "\f") { + return '\\f'; + } elsif ($n == ord "\r") { + return '\\r'; + } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) { + return '\\c' . chr(ord("@") + $n); + } else { +# return '\x' . sprintf("%02x", $n); + return '\\' . sprintf("%03o", $n); + } +} + +sub collapse { + my(@chars) = @_; + my($c, $str, $tr); + for ($c = 0; $c < @chars; $c++) { + $tr = $chars[$c]; + $str .= pchr($tr); + if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and + $chars[$c + 2] == $tr + 2) + { + for (; $c <= $#chars and $chars[$c + 1] == $chars[$c] + 1; $c++) {} + $str .= "-"; + $str .= pchr($chars[$c]); + } + } + return $str; +} + +sub OPpTRANS_SQUASH () { 16 } +sub OPpTRANS_DELETE () { 32 } +sub OPpTRANS_COMPLEMENT () { 64 } + +sub pp_trans { + my $self = shift; + my($op, $cx) = @_; + my(@table) = unpack("s256", $op->pv); + my($c, $tr, @from, @to, @delfrom, $delhyphen); + if ($table[ord "-"] != -1 and + $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1) + { + $tr = $table[ord "-"]; + $table[ord "-"] = -1; + if ($tr >= 0) { + @from = ord("-"); + @to = $tr; + } else { # -2 ==> delete + $delhyphen = 1; + } + } + for ($c = 0; $c < 256; $c++) { + $tr = $table[$c]; + if ($tr >= 0) { + push @from, $c; push @to, $tr; + } elsif ($tr == -2) { + push @delfrom, $c; + } + } + my $flags; + @from = (@from, @delfrom); + if ($op->private & OPpTRANS_COMPLEMENT) { + $flags .= "c"; + my @newfrom = (); + my %from; + @from{@from} = (1) x @from; + for ($c = 0; $c < 256; $c++) { + push @newfrom, $c unless $from{$c}; + } + @from = @newfrom; + } + if ($op->private & OPpTRANS_DELETE) { + $flags .= "d"; + } else { + pop @to while $#to and $to[$#to] == $to[$#to -1]; + } + $flags .= "s" if $op->private & OPpTRANS_SQUASH; + my($from, $to); + $from = collapse(@from); + $to = collapse(@to); + $from .= "-" if $delhyphen; + return "tr" . double_delim($from, $to) . $flags; +} + +# Like dq(), but different +sub re_dq { + my $self = shift; + my $op = shift; + my $type = $op->ppaddr; + if ($type eq "pp_const") { + return uninterp($op->sv->PV); + } elsif ($type eq "pp_concat") { + return $self->re_dq($op->first) . $self->re_dq($op->last); + } elsif ($type eq "pp_uc") { + return '\U' . $self->re_dq($op->first->sibling) . '\E'; + } elsif ($type eq "pp_lc") { + return '\L' . $self->re_dq($op->first->sibling) . '\E'; + } elsif ($type eq "pp_ucfirst") { + return '\u' . $self->re_dq($op->first->sibling); + } elsif ($type eq "pp_lcfirst") { + return '\l' . $self->re_dq($op->first->sibling); + } elsif ($type eq "pp_quotemeta") { + return '\Q' . $self->re_dq($op->first->sibling) . '\E'; + } elsif ($type eq "pp_join") { + return $self->deparse($op->last, 26); # was join($", @ary) + } else { + return $self->deparse($op, 26); + } +} + +sub pp_regcomp { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first; + $kid = $kid->first if $kid->ppaddr eq "pp_regcmaybe"; + $kid = $kid->first if $kid->ppaddr eq "pp_regcreset"; + return $self->re_dq($kid); +} + +sub OPp_RUNTIME () { 64 } + +sub PMf_ONCE () { 0x2 } +sub PMf_SKIPWHITE () { 0x10 } +sub PMf_CONST () { 0x40 } +sub PMf_KEEP () { 0x80 } +sub PMf_GLOBAL () { 0x100 } +sub PMf_CONTINUE () { 0x200 } +sub PMf_EVAL () { 0x400 } +sub PMf_LOCALE () { 0x800 } +sub PMf_MULTILINE () { 0x1000 } +sub PMf_SINGLELINE () { 0x2000 } +sub PMf_FOLD () { 0x4000 } +sub PMf_EXTENDED () { 0x8000 } + +# osmic acid -- see osmium tetroxide + +my %matchwords; +map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs', + 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic', + 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi'); + +sub matchop { + my $self = shift; + my($op, $cx, $name, $delim) = @_; + my $kid = $op->first; + my ($binop, $var, $re) = ("", "", ""); + if ($op->flags & OPf_STACKED) { + $binop = 1; + $var = $self->deparse($kid, 20); + $kid = $kid->sibling; + } + if (null $kid) { + $re = re_uninterp(escape_str($op->precomp)); + } else { + $re = $self->deparse($kid, 1); + } + my $flags = ""; + $flags .= "c" if $op->pmflags & PMf_CONTINUE; + $flags .= "g" if $op->pmflags & PMf_GLOBAL; + $flags .= "i" if $op->pmflags & PMf_FOLD; + $flags .= "m" if $op->pmflags & PMf_MULTILINE; + $flags .= "o" if $op->pmflags & PMf_KEEP; + $flags .= "s" if $op->pmflags & PMf_SINGLELINE; + $flags .= "x" if $op->pmflags & PMf_EXTENDED; + $flags = $matchwords{$flags} if $matchwords{$flags}; + if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here + $re =~ s/\?/\\?/g; + $re = "?$re?"; + } else { + $re = single_delim($name, $delim, $re); + } + $re = $re . $flags; + if ($binop) { + return $self->maybe_parens("$var =~ $re", $cx, 20); + } else { + return $re; + } +} + +sub pp_match { matchop(@_, "m", "/") } +sub pp_pushre { matchop(@_, "m", "/") } +sub pp_qr { matchop(@_, "qr", "") } + +sub pp_split { + my $self = shift; + my($op, $cx) = @_; + my($kid, @exprs, $ary, $expr); + $kid = $op->first; + if ($ {$kid->pmreplroot}) { + $ary = '@' . $self->gv_name($kid->pmreplroot); + } + for (; !null($kid); $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, 6); + } + $expr = "split(" . join(", ", @exprs) . ")"; + if ($ary) { + return $self->maybe_parens("$ary = $expr", $cx, 7); + } else { + return $expr; + } +} + +# oxime -- any of various compounds obtained chiefly by the action of +# hydroxylamine on aldehydes and ketones and characterized by the +# bivalent grouping C=NOH [Webster's Tenth] + +my %substwords; +map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em', + 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me', + 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem', + 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi'); + +sub pp_subst { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first; + my($binop, $var, $re, $repl) = ("", "", "", ""); + if ($op->flags & OPf_STACKED) { + $binop = 1; + $var = $self->deparse($kid, 20); + $kid = $kid->sibling; + } + my $flags = ""; + if (null($op->pmreplroot)) { + $repl = $self->dq($kid); + $kid = $kid->sibling; + } else { + $repl = $op->pmreplroot->first; # skip substcont + while ($repl->ppaddr eq "pp_entereval") { + $repl = $repl->first; + $flags .= "e"; + } + $repl = $self->dq($repl); + } + if (null $kid) { + $re = re_uninterp(escape_str($op->precomp)); + } else { + $re = $self->deparse($kid, 1); + } + $flags .= "e" if $op->pmflags & PMf_EVAL; + $flags .= "g" if $op->pmflags & PMf_GLOBAL; + $flags .= "i" if $op->pmflags & PMf_FOLD; + $flags .= "m" if $op->pmflags & PMf_MULTILINE; + $flags .= "o" if $op->pmflags & PMf_KEEP; + $flags .= "s" if $op->pmflags & PMf_SINGLELINE; + $flags .= "x" if $op->pmflags & PMf_EXTENDED; + $flags = $substwords{$flags} if $substwords{$flags}; + if ($binop) { + return $self->maybe_parens("$var =~ s" + . double_delim($re, $repl) . $flags, + $cx, 20); + } else { + return "s". double_delim($re, $repl) . $flags; + } +} + +1; +__END__ + +=head1 NAME + +B::Deparse - Perl compiler backend to produce perl code + +=head1 SYNOPSIS + +B B<-MO=Deparse>[B<,-u>I][B<,-p>][B<,-l>][B<,-s>I] I + +=head1 DESCRIPTION + +B::Deparse is a backend module for the Perl compiler that generates +perl source code, based on the internal compiled structure that perl +itself creates after parsing a program. The output of B::Deparse won't +be exactly the same as the original source, since perl doesn't keep +track of comments or whitespace, and there isn't a one-to-one +correspondence between perl's syntactical constructions and their +compiled form, but it will often be close. When you use the B<-p> +option, the output also includes parentheses even when they are not +required by precedence, which can make it easy to see if perl is +parsing your expressions the way you intended. + +Please note that this module is mainly new and untested code and is +still under development, so it may change in the future. + +=head1 OPTIONS + +As with all compiler backend options, these must follow directly after +the '-MO=Deparse', separated by a comma but not any white space. + +=over 4 + +=item B<-p> + +Print extra parentheses. Without this option, B::Deparse includes +parentheses in its output only when they are needed, based on the +structure of your program. With B<-p>, it uses parentheses (almost) +whenever they would be legal. This can be useful if you are used to +LISP, or if you want to see how perl parses your input. If you say + + if ($var & 0x7f == 65) {print "Gimme an A!"} + print ($which ? $a : $b), "\n"; + $name = $ENV{USER} or "Bob"; + +C will print + + if (($var & 0)) { + print('Gimme an A!') + }; + (print(($which ? $a : $b)), '???'); + (($name = $ENV{'USER'}) or '???') + +which probably isn't what you intended (the C<'???'> is a sign that +perl optimized away a constant value). + +=item B<-u>I + +Normally, B::Deparse deparses the main code of a program, all the subs +called by the main program (and all the subs called by them, +recursively), and any other subs in the main:: package. To include +subs in other packages that aren't called directly, such as AUTOLOAD, +DESTROY, other subs called automatically by perl, and methods, which +aren't resolved to subs until runtime, use the B<-u> option. The +argument to B<-u> is the name of a package, and should follow directly +after the 'u'. Multiple B<-u> options may be given, separated by +commas. Note that unlike some other backends, B::Deparse doesn't +(yet) try to guess automatically when B<-u> is needed -- you must +invoke it yourself. + +=item B<-l> + +Add '#line' declarations to the output based on the line and file +locations of the original code. + +=item B<-s>I + +Tweak the style of B::Deparse's output. At the moment, only one style +option is implemented: + +=over 4 + +=item B + +Cuddle C, C, and C blocks. For example, print + + if (...) { + ... + } else { + ... + } + +instead of + + if (...) { + ... + } + else { + ... + } + +The default is not to cuddle. + +=back + +=back + +=head1 BUGS + +See the 'to do' list at the beginning of the module file. + +=head1 AUTHOR + +Stephen McCamant , based on an earlier version by +Malcolm Beattie . + +=cut diff --git a/contrib/perl5/ext/B/B/Disassembler.pm b/contrib/perl5/ext/B/B/Disassembler.pm new file mode 100644 index 0000000..f26441d --- /dev/null +++ b/contrib/perl5/ext/B/B/Disassembler.pm @@ -0,0 +1,164 @@ +# Disassembler.pm +# +# Copyright (c) 1996 Malcolm Beattie +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the README file. +package B::Disassembler::BytecodeStream; +use FileHandle; +use Carp; +use B qw(cstring cast_I32); +@ISA = qw(FileHandle); +sub readn { + my ($fh, $len) = @_; + my $data; + read($fh, $data, $len); + croak "reached EOF while reading $len bytes" unless length($data) == $len; + return $data; +} + +sub GET_U8 { + my $fh = shift; + my $c = $fh->getc; + croak "reached EOF while reading U8" unless defined($c); + return ord($c); +} + +sub GET_U16 { + my $fh = shift; + my $str = $fh->readn(2); + croak "reached EOF while reading U16" unless length($str) == 2; + return unpack("n", $str); +} + +sub GET_U32 { + my $fh = shift; + my $str = $fh->readn(4); + croak "reached EOF while reading U32" unless length($str) == 4; + return unpack("N", $str); +} + +sub GET_I32 { + my $fh = shift; + my $str = $fh->readn(4); + croak "reached EOF while reading I32" unless length($str) == 4; + return cast_I32(unpack("N", $str)); +} + +sub GET_objindex { + my $fh = shift; + my $str = $fh->readn(4); + croak "reached EOF while reading objindex" unless length($str) == 4; + return unpack("N", $str); +} + +sub GET_strconst { + my $fh = shift; + my ($str, $c); + while (defined($c = $fh->getc) && $c ne "\0") { + $str .= $c; + } + croak "reached EOF while reading strconst" unless defined($c); + return cstring($str); +} + +sub GET_pvcontents {} + +sub GET_PV { + my $fh = shift; + my $str; + my $len = $fh->GET_U32; + if ($len) { + read($fh, $str, $len); + croak "reached EOF while reading PV" unless length($str) == $len; + return cstring($str); + } else { + return '""'; + } +} + +sub GET_comment { + my $fh = shift; + my ($str, $c); + while (defined($c = $fh->getc) && $c ne "\n") { + $str .= $c; + } + croak "reached EOF while reading comment" unless defined($c); + return cstring($str); +} + +sub GET_double { + my $fh = shift; + my ($str, $c); + while (defined($c = $fh->getc) && $c ne "\0") { + $str .= $c; + } + croak "reached EOF while reading double" unless defined($c); + return $str; +} + +sub GET_none {} + +sub GET_op_tr_array { + my $fh = shift; + my @ary = unpack("n256", $fh->readn(256 * 2)); + return join(",", @ary); +} + +sub GET_IV64 { + my $fh = shift; + my ($hi, $lo) = unpack("NN", $fh->readn(8)); + return sprintf("0x%4x%04x", $hi, $lo); # cheat +} + +package B::Disassembler; +use Exporter; +@ISA = qw(Exporter); +@EXPORT_OK = qw(disassemble_fh); +use Carp; +use strict; + +use B::Asmdata qw(%insn_data @insn_name); + +sub disassemble_fh { + my ($fh, $out) = @_; + my ($c, $getmeth, $insn, $arg); + bless $fh, "B::Disassembler::BytecodeStream"; + while (defined($c = $fh->getc)) { + $c = ord($c); + $insn = $insn_name[$c]; + if (!defined($insn) || $insn eq "unused") { + my $pos = $fh->tell - 1; + die "Illegal instruction code $c at stream offset $pos\n"; + } + $getmeth = $insn_data{$insn}->[2]; + $arg = $fh->$getmeth(); + if (defined($arg)) { + &$out($insn, $arg); + } else { + &$out($insn); + } + } +} + +1; + +__END__ + +=head1 NAME + +B::Disassembler - Disassemble Perl bytecode + +=head1 SYNOPSIS + + use Disassembler; + +=head1 DESCRIPTION + +See F. + +=head1 AUTHOR + +Malcolm Beattie, C + +=cut diff --git a/contrib/perl5/ext/B/B/Lint.pm b/contrib/perl5/ext/B/B/Lint.pm new file mode 100644 index 0000000..d34bd77 --- /dev/null +++ b/contrib/perl5/ext/B/B/Lint.pm @@ -0,0 +1,367 @@ +package B::Lint; + +=head1 NAME + +B::Lint - Perl lint + +=head1 SYNOPSIS + +perl -MO=Lint[,OPTIONS] foo.pl + +=head1 DESCRIPTION + +The B::Lint module is equivalent to an extended version of the B<-w> +option of B. It is named after the program B which carries +out a similar process for C programs. + +=head1 OPTIONS AND LINT CHECKS + +Option words are separated by commas (not whitespace) and follow the +usual conventions of compiler backend options. Following any options +(indicated by a leading B<->) come lint check arguments. Each such +argument (apart from the special B and B options) is a +word representing one possible lint check (turning on that check) or +is B (turning off that check). Before processing the check +arguments, a standard list of checks is turned on. Later options +override earlier ones. Available options are: + +=over 8 + +=item B + +Produces a warning whenever an array is used in an implicit scalar +context. For example, both of the lines + + $foo = length(@bar); + $foo = @bar; +will elicit a warning. Using an explicit B silences the +warning. For example, + + $foo = scalar(@bar); + +=item B and B + +These options produce a warning whenever an operation implicitly +reads or (respectively) writes to one of Perl's special variables. +For example, B will warn about these: + + /foo/; + +and B will warn about these: + + s/foo/bar/; + +Both B and B warn about this: + + for (@a) { ... } + +=item B + +This option warns whenever $_ is used either explicitly anywhere or +as the implicit argument of a B statement. + +=item B + +This option warns on each use of any variable, subroutine or +method name that lives in a non-current package but begins with +an underscore ("_"). Warnings aren't issued for the special case +of the single character name "_" by itself (e.g. $_ and @_). + +=item B + +This option warns whenever an undefined subroutine is invoked. +This option will only catch explicitly invoked subroutines such +as C and not indirect invocations such as C<&$subref()> +or C<$obj-Emeth()>. Note that some programs or modules delay +definition of subs until runtime by means of the AUTOLOAD +mechanism. + +=item B + +This option warns whenever one of the regexp variables $', $& or +$' is used. Any occurrence of any of these variables in your +program can slow your whole program down. See L for +details. + +=item B + +Turn all warnings on. + +=item B + +Turn all warnings off. + +=back + +=head1 NON LINT-CHECK OPTIONS + +=over 8 + +=item B<-u Package> + +Normally, Lint only checks the main code of the program together +with all subs defined in package main. The B<-u> option lets you +include other package names whose subs are then checked by Lint. + +=back + +=head1 BUGS + +This is only a very preliminary version. + +=head1 AUTHOR + +Malcolm Beattie, mbeattie@sable.ox.ac.uk. + +=cut + +use strict; +use B qw(walkoptree_slow main_root walksymtable svref_2object parents); + +# Constants (should probably be elsewhere) +sub G_ARRAY () { 1 } +sub OPf_LIST () { 1 } +sub OPf_KNOW () { 2 } +sub OPf_STACKED () { 64 } + +my $file = "unknown"; # shadows current filename +my $line = 0; # shadows current line number +my $curstash = "main"; # shadows current stash + +# Lint checks +my %check; +my %implies_ok_context; +BEGIN { + map($implies_ok_context{$_}++, + qw(pp_scalar pp_av2arylen pp_aelem pp_aslice pp_helem pp_hslice + pp_keys pp_values pp_hslice pp_defined pp_undef pp_delete)); +} + +# Lint checks turned on by default +my @default_checks = qw(context); + +my %valid_check; +# All valid checks +BEGIN { + map($valid_check{$_}++, + qw(context implicit_read implicit_write dollar_underscore + private_names undefined_subs regexp_variables)); +} + +# Debugging options +my ($debug_op); + +my %done_cv; # used to mark which subs have already been linted +my @extra_packages; # Lint checks mainline code and all subs which are + # in main:: or in one of these packages. + +sub warning { + my $format = (@_ < 2) ? "%s" : shift; + warn sprintf("$format at %s line %d\n", @_, $file, $line); +} + +# This gimme can't cope with context that's only determined +# at runtime via dowantarray(). +sub gimme { + my $op = shift; + my $flags = $op->flags; + if ($flags & OPf_KNOW) { + return(($flags & OPf_LIST) ? 1 : 0); + } + return undef; +} + +sub B::OP::lint {} + +sub B::COP::lint { + my $op = shift; + if ($op->ppaddr eq "pp_nextstate") { + $file = $op->filegv->SV->PV; + $line = $op->line; + $curstash = $op->stash->NAME; + } +} + +sub B::UNOP::lint { + my $op = shift; + my $ppaddr = $op->ppaddr; + if ($check{context} && ($ppaddr eq "pp_rv2av" || $ppaddr eq "pp_rv2hv")) { + my $parent = parents->[0]; + my $pname = $parent->ppaddr; + return if gimme($op) || $implies_ok_context{$pname}; + # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}" + # null out the parent so we have to check for a parent of pp_null and + # a grandparent of pp_enteriter or pp_delete + if ($pname eq "pp_null") { + my $gpname = parents->[1]->ppaddr; + return if $gpname eq "pp_enteriter" || $gpname eq "pp_delete"; + } + warning("Implicit scalar context for %s in %s", + $ppaddr eq "pp_rv2av" ? "array" : "hash", $parent->desc); + } + if ($check{private_names} && $ppaddr eq "pp_method") { + my $methop = $op->first; + if ($methop->ppaddr eq "pp_const") { + my $method = $methop->sv->PV; + if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) { + warning("Illegal reference to private method name $method"); + } + } + } +} + +sub B::PMOP::lint { + my $op = shift; + if ($check{implicit_read}) { + my $ppaddr = $op->ppaddr; + if ($ppaddr eq "pp_match" && !($op->flags & OPf_STACKED)) { + warning('Implicit match on $_'); + } + } + if ($check{implicit_write}) { + my $ppaddr = $op->ppaddr; + if ($ppaddr eq "pp_subst" && !($op->flags & OPf_STACKED)) { + warning('Implicit substitution on $_'); + } + } +} + +sub B::LOOP::lint { + my $op = shift; + if ($check{implicit_read} || $check{implicit_write}) { + my $ppaddr = $op->ppaddr; + if ($ppaddr eq "pp_enteriter") { + my $last = $op->last; + if ($last->ppaddr eq "pp_gv" && $last->gv->NAME eq "_") { + warning('Implicit use of $_ in foreach'); + } + } + } +} + +sub B::GVOP::lint { + my $op = shift; + if ($check{dollar_underscore} && $op->ppaddr eq "pp_gvsv" + && $op->gv->NAME eq "_") + { + warning('Use of $_'); + } + if ($check{private_names}) { + my $ppaddr = $op->ppaddr; + my $gv = $op->gv; + if (($ppaddr eq "pp_gv" || $ppaddr eq "pp_gvsv") + && $gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) + { + warning('Illegal reference to private name %s', $gv->NAME); + } + } + if ($check{undefined_subs}) { + if ($op->ppaddr eq "pp_gv" && $op->next->ppaddr eq "pp_entersub") { + my $gv = $op->gv; + my $subname = $gv->STASH->NAME . "::" . $gv->NAME; + no strict 'refs'; + if (!defined(&$subname)) { + $subname =~ s/^main:://; + warning('Undefined subroutine %s called', $subname); + } + } + } + if ($check{regexp_variables} && $op->ppaddr eq "pp_gvsv") { + my $name = $op->gv->NAME; + if ($name =~ /^[&'`]$/) { + warning('Use of regexp variable $%s', $name); + } + } +} + +sub B::GV::lintcv { + my $gv = shift; + my $cv = $gv->CV; + #warn sprintf("lintcv: %s::%s (done=%d)\n", + # $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug + return if !$$cv || $done_cv{$$cv}++; + my $root = $cv->ROOT; + #warn " root = $root (0x$$root)\n";#debug + walkoptree_slow($root, "lint") if $$root; +} + +sub do_lint { + my %search_pack; + walkoptree_slow(main_root, "lint") if ${main_root()}; + + # Now do subs in main + no strict qw(vars refs); + my $sym; + local(*glob); + while (($sym, *glob) = each %{"main::"}) { + #warn "Trying $sym\n";#debug + svref_2object(\*glob)->EGV->lintcv unless $sym =~ /::$/; + } + + # Now do subs in non-main packages given by -u options + map { $search_pack{$_} = 1 } @extra_packages; + walksymtable(\%{"main::"}, "lintcv", sub { + my $package = shift; + $package =~ s/::$//; + #warn "Considering $package\n";#debug + return exists $search_pack{$package}; + }); +} + +sub compile { + my @options = @_; + my ($option, $opt, $arg); + # Turn on default lint checks + for $opt (@default_checks) { + $check{$opt} = 1; + } + OPTION: + while ($option = shift @options) { + if ($option =~ /^-(.)(.*)/) { + $opt = $1; + $arg = $2; + } else { + unshift @options, $option; + last OPTION; + } + if ($opt eq "-" && $arg eq "-") { + shift @options; + last OPTION; + } elsif ($opt eq "D") { + $arg ||= shift @options; + foreach $arg (split(//, $arg)) { + if ($arg eq "o") { + B->debug(1); + } elsif ($arg eq "O") { + $debug_op = 1; + } + } + } elsif ($opt eq "u") { + $arg ||= shift @options; + push(@extra_packages, $arg); + } + } + foreach $opt (@default_checks, @options) { + $opt =~ tr/-/_/; + if ($opt eq "all") { + %check = %valid_check; + } + elsif ($opt eq "none") { + %check = (); + } + else { + if ($opt =~ s/^no-//) { + $check{$opt} = 0; + } + else { + $check{$opt} = 1; + } + warn "No such check: $opt\n" unless defined $valid_check{$opt}; + } + } + # Remaining arguments are things to check + + return \&do_lint; +} + +1; diff --git a/contrib/perl5/ext/B/B/Showlex.pm b/contrib/perl5/ext/B/B/Showlex.pm new file mode 100644 index 0000000..648f95d --- /dev/null +++ b/contrib/perl5/ext/B/B/Showlex.pm @@ -0,0 +1,80 @@ +package B::Showlex; +use strict; +use B qw(svref_2object comppadlist class); +use B::Terse (); + +# +# Invoke as +# perl -MO=Showlex,foo bar.pl +# to see the names of lexical variables used by &foo +# or as +# perl -MO=Showlex bar.pl +# to see the names of file scope lexicals used by bar.pl +# + +sub showarray { + my ($name, $av) = @_; + my @els = $av->ARRAY; + my $count = @els; + my $i; + print "$name has $count entries\n"; + for ($i = 0; $i < $count; $i++) { + print "$i: "; + $els[$i]->terse; + } +} + +sub showlex { + my ($objname, $namesav, $valsav) = @_; + showarray("Pad of lexical names for $objname", $namesav); + showarray("Pad of lexical values for $objname", $valsav); +} + +sub showlex_obj { + my ($objname, $obj) = @_; + $objname =~ s/^&main::/&/; + showlex($objname, svref_2object($obj)->PADLIST->ARRAY); +} + +sub showlex_main { + showlex("comppadlist", comppadlist->ARRAY); +} + +sub compile { + my @options = @_; + if (@options) { + return sub { + my $objname; + foreach $objname (@options) { + $objname = "main::$objname" unless $objname =~ /::/; + eval "showlex_obj('&$objname', \\&$objname)"; + } + } + } else { + return \&showlex_main; + } +} + +1; + +__END__ + +=head1 NAME + +B::Showlex - Show lexical variables used in functions or files + +=head1 SYNOPSIS + + perl -MO=Showlex[,SUBROUTINE] foo.pl + +=head1 DESCRIPTION + +When a subroutine name is provided in OPTIONS, prints the lexical +variables used in that subroutine. Otherwise, prints the file-scope +lexicals in the file. + +=head1 AUTHOR + +Malcolm Beattie, C + +=cut diff --git a/contrib/perl5/ext/B/B/Stackobj.pm b/contrib/perl5/ext/B/B/Stackobj.pm new file mode 100644 index 0000000..eea966c --- /dev/null +++ b/contrib/perl5/ext/B/B/Stackobj.pm @@ -0,0 +1,301 @@ +# Stackobj.pm +# +# Copyright (c) 1996 Malcolm Beattie +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the README file. +# +package B::Stackobj; +use Exporter (); +@ISA = qw(Exporter); +@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT + VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY); +%EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)], + flags => [qw(VALID_INT VALID_DOUBLE VALID_SV + REGISTER TEMPORARY)]); + +use Carp qw(confess); +use strict; +use B qw(class); + +# Perl internal constants that I should probably define elsewhere. +sub SVf_IOK () { 0x10000 } +sub SVf_NOK () { 0x20000 } + +# Types +sub T_UNKNOWN () { 0 } +sub T_DOUBLE () { 1 } +sub T_INT () { 2 } + +# Flags +sub VALID_INT () { 0x01 } +sub VALID_DOUBLE () { 0x02 } +sub VALID_SV () { 0x04 } +sub REGISTER () { 0x08 } # no implicit write-back when calling subs +sub TEMPORARY () { 0x10 } # no implicit write-back needed at all + +# +# Callback for runtime code generation +# +my $runtime_callback = sub { confess "set_callback not yet called" }; +sub set_callback (&) { $runtime_callback = shift } +sub runtime { &$runtime_callback(@_) } + +# +# Methods +# + +sub write_back { confess "stack object does not implement write_back" } + +sub invalidate { shift->{flags} &= ~(VALID_INT | VALID_DOUBLE) } + +sub as_sv { + my $obj = shift; + if (!($obj->{flags} & VALID_SV)) { + $obj->write_back; + $obj->{flags} |= VALID_SV; + } + return $obj->{sv}; +} + +sub as_int { + my $obj = shift; + if (!($obj->{flags} & VALID_INT)) { + $obj->load_int; + $obj->{flags} |= VALID_INT; + } + return $obj->{iv}; +} + +sub as_double { + my $obj = shift; + if (!($obj->{flags} & VALID_DOUBLE)) { + $obj->load_double; + $obj->{flags} |= VALID_DOUBLE; + } + return $obj->{nv}; +} + +sub as_numeric { + my $obj = shift; + return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double; +} + +# +# Debugging methods +# +sub peek { + my $obj = shift; + my $type = $obj->{type}; + my $flags = $obj->{flags}; + my @flags; + if ($type == T_UNKNOWN) { + $type = "T_UNKNOWN"; + } elsif ($type == T_INT) { + $type = "T_INT"; + } elsif ($type == T_DOUBLE) { + $type = "T_DOUBLE"; + } else { + $type = "(illegal type $type)"; + } + push(@flags, "VALID_INT") if $flags & VALID_INT; + push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE; + push(@flags, "VALID_SV") if $flags & VALID_SV; + push(@flags, "REGISTER") if $flags & REGISTER; + push(@flags, "TEMPORARY") if $flags & TEMPORARY; + @flags = ("none") unless @flags; + return sprintf("%s type=$type flags=%s sv=$obj->{sv}", + class($obj), join("|", @flags)); +} + +sub minipeek { + my $obj = shift; + my $type = $obj->{type}; + my $flags = $obj->{flags}; + if ($type == T_INT || $flags & VALID_INT) { + return $obj->{iv}; + } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) { + return $obj->{nv}; + } else { + return $obj->{sv}; + } +} + +# +# Caller needs to ensure that set_int, set_double, +# set_numeric and set_sv are only invoked on legal lvalues. +# +sub set_int { + my ($obj, $expr) = @_; + runtime("$obj->{iv} = $expr;"); + $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE); + $obj->{flags} |= VALID_INT; +} + +sub set_double { + my ($obj, $expr) = @_; + runtime("$obj->{nv} = $expr;"); + $obj->{flags} &= ~(VALID_SV | VALID_INT); + $obj->{flags} |= VALID_DOUBLE; +} + +sub set_numeric { + my ($obj, $expr) = @_; + if ($obj->{type} == T_INT) { + $obj->set_int($expr); + } else { + $obj->set_double($expr); + } +} + +sub set_sv { + my ($obj, $expr) = @_; + runtime("SvSetSV($obj->{sv}, $expr);"); + $obj->invalidate; + $obj->{flags} |= VALID_SV; +} + +# +# Stackobj::Padsv +# + +@B::Stackobj::Padsv::ISA = 'B::Stackobj'; +sub B::Stackobj::Padsv::new { + my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_; + bless { + type => $type, + flags => VALID_SV | $extra_flags, + sv => "PL_curpad[$ix]", + iv => "$iname", + nv => "$dname" + }, $class; +} + +sub B::Stackobj::Padsv::load_int { + my $obj = shift; + if ($obj->{flags} & VALID_DOUBLE) { + runtime("$obj->{iv} = $obj->{nv};"); + } else { + runtime("$obj->{iv} = SvIV($obj->{sv});"); + } + $obj->{flags} |= VALID_INT; +} + +sub B::Stackobj::Padsv::load_double { + my $obj = shift; + $obj->write_back; + runtime("$obj->{nv} = SvNV($obj->{sv});"); + $obj->{flags} |= VALID_DOUBLE; +} + +sub B::Stackobj::Padsv::write_back { + my $obj = shift; + my $flags = $obj->{flags}; + return if $flags & VALID_SV; + if ($flags & VALID_INT) { + runtime("sv_setiv($obj->{sv}, $obj->{iv});"); + } elsif ($flags & VALID_DOUBLE) { + runtime("sv_setnv($obj->{sv}, $obj->{nv});"); + } else { + confess "write_back failed for lexical @{[$obj->peek]}\n"; + } + $obj->{flags} |= VALID_SV; +} + +# +# Stackobj::Const +# + +@B::Stackobj::Const::ISA = 'B::Stackobj'; +sub B::Stackobj::Const::new { + my ($class, $sv) = @_; + my $obj = bless { + flags => 0, + sv => $sv # holds the SV object until write_back happens + }, $class; + my $svflags = $sv->FLAGS; + if ($svflags & SVf_IOK) { + $obj->{flags} = VALID_INT|VALID_DOUBLE; + $obj->{type} = T_INT; + $obj->{nv} = $obj->{iv} = $sv->IV; + } elsif ($svflags & SVf_NOK) { + $obj->{flags} = VALID_INT|VALID_DOUBLE; + $obj->{type} = T_DOUBLE; + $obj->{iv} = $obj->{nv} = $sv->NV; + } else { + $obj->{type} = T_UNKNOWN; + } + return $obj; +} + +sub B::Stackobj::Const::write_back { + my $obj = shift; + return if $obj->{flags} & VALID_SV; + # Save the SV object and replace $obj->{sv} by its C source code name + $obj->{sv} = $obj->{sv}->save; + $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE; +} + +sub B::Stackobj::Const::load_int { + my $obj = shift; + $obj->{iv} = int($obj->{sv}->PV); + $obj->{flags} |= VALID_INT; +} + +sub B::Stackobj::Const::load_double { + my $obj = shift; + $obj->{nv} = $obj->{sv}->PV + 0.0; + $obj->{flags} |= VALID_DOUBLE; +} + +sub B::Stackobj::Const::invalidate {} + +# +# Stackobj::Bool +# + +@B::Stackobj::Bool::ISA = 'B::Stackobj'; +sub B::Stackobj::Bool::new { + my ($class, $preg) = @_; + my $obj = bless { + type => T_INT, + flags => VALID_INT|VALID_DOUBLE, + iv => $$preg, + nv => $$preg, + preg => $preg # this holds our ref to the pseudo-reg + }, $class; + return $obj; +} + +sub B::Stackobj::Bool::write_back { + my $obj = shift; + return if $obj->{flags} & VALID_SV; + $obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)"; + $obj->{flags} |= VALID_SV; +} + +# XXX Might want to handle as_double/set_double/load_double? + +sub B::Stackobj::Bool::invalidate {} + +1; + +__END__ + +=head1 NAME + +B::Stackobj - Helper module for CC backend + +=head1 SYNOPSIS + + use B::Stackobj; + +=head1 DESCRIPTION + +See F. + +=head1 AUTHOR + +Malcolm Beattie, C + +=cut diff --git a/contrib/perl5/ext/B/B/Terse.pm b/contrib/perl5/ext/B/B/Terse.pm new file mode 100644 index 0000000..93757f3 --- /dev/null +++ b/contrib/perl5/ext/B/B/Terse.pm @@ -0,0 +1,152 @@ +package B::Terse; +use strict; +use B qw(peekop class walkoptree_slow walkoptree_exec + main_start main_root cstring svref_2object); +use B::Asmdata qw(@specialsv_name); + +sub terse { + my ($order, $cvref) = @_; + my $cv = svref_2object($cvref); + if ($order eq "exec") { + walkoptree_exec($cv->START, "terse"); + } else { + walkoptree_slow($cv->ROOT, "terse"); + } +} + +sub compile { + my $order = shift; + my @options = @_; + if (@options) { + return sub { + my $objname; + foreach $objname (@options) { + $objname = "main::$objname" unless $objname =~ /::/; + eval "terse(\$order, \\&$objname)"; + die "terse($order, \\&$objname) failed: $@" if $@; + } + } + } else { + if ($order eq "exec") { + return sub { walkoptree_exec(main_start, "terse") } + } else { + return sub { walkoptree_slow(main_root, "terse") } + } + } +} + +sub indent { + my $level = shift; + return " " x $level; +} + +sub B::OP::terse { + my ($op, $level) = @_; + my $targ = $op->targ; + $targ = ($targ > 0) ? " [$targ]" : ""; + print indent($level), peekop($op), $targ, "\n"; +} + +sub B::SVOP::terse { + my ($op, $level) = @_; + print indent($level), peekop($op), " "; + $op->sv->terse(0); +} + +sub B::GVOP::terse { + my ($op, $level) = @_; + print indent($level), peekop($op), " "; + $op->gv->terse(0); +} + +sub B::PMOP::terse { + my ($op, $level) = @_; + my $precomp = $op->precomp; + print indent($level), peekop($op), + defined($precomp) ? " /$precomp/\n" : " (regexp not compiled)\n"; + +} + +sub B::PVOP::terse { + my ($op, $level) = @_; + print indent($level), peekop($op), " ", cstring($op->pv), "\n"; +} + +sub B::COP::terse { + my ($op, $level) = @_; + my $label = $op->label; + if ($label) { + $label = " label ".cstring($label); + } + print indent($level), peekop($op), $label, "\n"; +} + +sub B::PV::terse { + my ($sv, $level) = @_; + print indent($level); + printf "%s (0x%lx) %s\n", class($sv), $$sv, cstring($sv->PV); +} + +sub B::AV::terse { + my ($sv, $level) = @_; + print indent($level); + printf "%s (0x%lx) FILL %d\n", class($sv), $$sv, $sv->FILL; +} + +sub B::GV::terse { + my ($gv, $level) = @_; + my $stash = $gv->STASH->NAME; + if ($stash eq "main") { + $stash = ""; + } else { + $stash = $stash . "::"; + } + print indent($level); + printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->NAME; +} + +sub B::IV::terse { + my ($sv, $level) = @_; + print indent($level); + printf "%s (0x%lx) %d\n", class($sv), $$sv, $sv->IV; +} + +sub B::NV::terse { + my ($sv, $level) = @_; + print indent($level); + printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->NV; +} + +sub B::NULL::terse { + my ($sv, $level) = @_; + print indent($level); + printf "%s (0x%lx)\n", class($sv), $$sv; +} + +sub B::SPECIAL::terse { + my ($sv, $level) = @_; + print indent($level); + printf "%s #%d %s\n", class($sv), $$sv, $specialsv_name[$$sv]; +} + +1; + +__END__ + +=head1 NAME + +B::Terse - Walk Perl syntax tree, printing terse info about ops + +=head1 SYNOPSIS + + perl -MO=Terse[,OPTIONS] foo.pl + +=head1 DESCRIPTION + +See F. + +=head1 AUTHOR + +Malcolm Beattie, C + +=cut diff --git a/contrib/perl5/ext/B/B/Xref.pm b/contrib/perl5/ext/B/B/Xref.pm new file mode 100644 index 0000000..0102856 --- /dev/null +++ b/contrib/perl5/ext/B/B/Xref.pm @@ -0,0 +1,392 @@ +package B::Xref; + +=head1 NAME + +B::Xref - Generates cross reference reports for Perl programs + +=head1 SYNOPSIS + +perl -MO=Xref[,OPTIONS] foo.pl + +=head1 DESCRIPTION + +The B::Xref module is used to generate a cross reference listing of all +definitions and uses of variables, subroutines and formats in a Perl program. +It is implemented as a backend for the Perl compiler. + +The report generated is in the following format: + + File filename1 + Subroutine subname1 + Package package1 + object1 C + object2 C + ... + Package package2 + ... + +Each B section reports on a single file. Each B section +reports on a single subroutine apart from the special cases +"(definitions)" and "(main)". These report, respectively, on subroutine +definitions found by the initial symbol table walk and on the main part of +the program or module external to all subroutines. + +The report is then grouped by the B of each variable, +subroutine or format with the special case "(lexicals)" meaning +lexical variables. Each B name (implicitly qualified by its +containing B) includes its type character(s) at the beginning +where possible. Lexical variables are easier to track and even +included dereferencing information where possible. + +The C are a comma separated list of line numbers (some +preceded by code letters) where that object is used in some way. +Simple uses aren't preceded by a code letter. Introductions (such as +where a lexical is first defined with C) are indicated with the +letter "i". Subroutine and method calls are indicated by the character +"&". Subroutine definitions are indicated by "s" and format +definitions by "f". + +=head1 OPTIONS + +Option words are separated by commas (not whitespace) and follow the +usual conventions of compiler backend options. + +=over 8 + +=item C<-oFILENAME> + +Directs output to C instead of standard output. + +=item C<-r> + +Raw output. Instead of producing a human-readable report, outputs a line +in machine-readable form for each definition/use of a variable/sub/format. + +=item C<-D[tO]> + +(Internal) debug options, probably only useful if C<-r> included. +The C option prints the object on the top of the stack as it's +being tracked. The C option prints each operator as it's being +processed in the execution order of the program. + +=back + +=head1 BUGS + +Non-lexical variables are quite difficult to track through a program. +Sometimes the type of a non-lexical variable's use is impossible to +determine. Introductions of non-lexical non-scalars don't seem to be +reported properly. + +=head1 AUTHOR + +Malcolm Beattie, mbeattie@sable.ox.ac.uk. + +=cut + +use strict; +use B qw(peekop class comppadlist main_start svref_2object walksymtable); + +# Constants (should probably be elsewhere) +sub OPpLVAL_INTRO () { 128 } +sub SVf_POK () { 0x40000 } + +sub UNKNOWN { ["?", "?", "?"] } + +my @pad; # lexicals in current pad + # as ["(lexical)", type, name] +my %done; # keyed by $$op: set when each $op is done +my $top = UNKNOWN; # shadows top element of stack as + # [pack, type, name] (pack can be "(lexical)") +my $file; # shadows current filename +my $line; # shadows current line number +my $subname; # shadows current sub name +my %table; # Multi-level hash to record all uses etc. +my @todo = (); # List of CVs that need processing + +my %code = (intro => "i", used => "", + subdef => "s", subused => "&", + formdef => "f", meth => "->"); + + +# Options +my ($debug_op, $debug_top, $nodefs, $raw); + +sub process { + my ($var, $event) = @_; + my ($pack, $type, $name) = @$var; + if ($type eq "*") { + if ($event eq "used") { + return; + } elsif ($event eq "subused") { + $type = "&"; + } + } + $type =~ s/(.)\*$/$1/g; + if ($raw) { + printf "%-16s %-12s %5d %-12s %4s %-16s %s\n", + $file, $subname, $line, $pack, $type, $name, $event; + } else { + # Wheee + push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}}, + $line); + } +} + +sub load_pad { + my $padlist = shift; + my ($namelistav, @namelist, $ix); + @pad = (); + return if class($padlist) eq "SPECIAL"; + ($namelistav) = $padlist->ARRAY; + @namelist = $namelistav->ARRAY; + for ($ix = 1; $ix < @namelist; $ix++) { + my $namesv = $namelist[$ix]; + next if class($namesv) eq "SPECIAL"; + my ($type, $name) = $namesv->PV =~ /^(.)(.*)$/; + $pad[$ix] = ["(lexical)", $type, $name]; + } +} + +sub xref { + my $start = shift; + my $op; + for ($op = $start; $$op; $op = $op->next) { + last if $done{$$op}++; + warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top; + warn peekop($op), "\n" if $debug_op; + my $ppname = $op->ppaddr; + if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile)$/) { + xref($op->other); + } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") { + xref($op->pmreplstart); + } elsif ($ppname eq "pp_substcont") { + xref($op->other->pmreplstart); + $op = $op->other; + redo; + } elsif ($ppname eq "pp_cond_expr") { + # pp_cond_expr never returns op_next + xref($op->true); + $op = $op->false; + redo; + } elsif ($ppname eq "pp_enterloop") { + xref($op->redoop); + xref($op->nextop); + xref($op->lastop); + } elsif ($ppname eq "pp_subst") { + xref($op->pmreplstart); + } else { + no strict 'refs'; + &$ppname($op) if defined(&$ppname); + } + } +} + +sub xref_cv { + my $cv = shift; + my $pack = $cv->GV->STASH->NAME; + $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME; + load_pad($cv->PADLIST); + xref($cv->START); + $subname = "(main)"; +} + +sub xref_object { + my $cvref = shift; + xref_cv(svref_2object($cvref)); +} + +sub xref_main { + $subname = "(main)"; + load_pad(comppadlist); + xref(main_start); + while (@todo) { + xref_cv(shift @todo); + } +} + +sub pp_nextstate { + my $op = shift; + $file = $op->filegv->SV->PV; + $line = $op->line; + $top = UNKNOWN; +} + +sub pp_padsv { + my $op = shift; + $top = $pad[$op->targ]; + process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); +} + +sub pp_padav { pp_padsv(@_) } +sub pp_padhv { pp_padsv(@_) } + +sub deref { + my ($var, $as) = @_; + $var->[1] = $as . $var->[1]; + process($var, "used"); +} + +sub pp_rv2cv { deref($top, "&"); } +sub pp_rv2hv { deref($top, "%"); } +sub pp_rv2sv { deref($top, "\$"); } +sub pp_rv2av { deref($top, "\@"); } +sub pp_rv2gv { deref($top, "*"); } + +sub pp_gvsv { + my $op = shift; + my $gv = $op->gv; + $top = [$gv->STASH->NAME, '$', $gv->NAME]; + process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); +} + +sub pp_gv { + my $op = shift; + my $gv = $op->gv; + $top = [$gv->STASH->NAME, "*", $gv->NAME]; + process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); +} + +sub pp_const { + my $op = shift; + my $sv = $op->sv; + $top = ["?", "", + (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"]; +} + +sub pp_method { + my $op = shift; + $top = ["(method)", "->".$top->[1], $top->[2]]; +} + +sub pp_entersub { + my $op = shift; + if ($top->[1] eq "m") { + process($top, "meth"); + } else { + process($top, "subused"); + } + $top = UNKNOWN; +} + +# +# Stuff for cross referencing definitions of variables and subs +# + +sub B::GV::xref { + my $gv = shift; + my $cv = $gv->CV; + if ($$cv) { + #return if $done{$$cv}++; + $file = $gv->FILEGV->SV->PV; + $line = $gv->LINE; + process([$gv->STASH->NAME, "&", $gv->NAME], "subdef"); + push(@todo, $cv); + } + my $form = $gv->FORM; + if ($$form) { + return if $done{$$form}++; + $file = $gv->FILEGV->SV->PV; + $line = $gv->LINE; + process([$gv->STASH->NAME, "", $gv->NAME], "formdef"); + } +} + +sub xref_definitions { + my ($pack, %exclude); + return if $nodefs; + $subname = "(definitions)"; + foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS + strict vars FileHandle Exporter Carp)) { + $exclude{$pack."::"} = 1; + } + no strict qw(vars refs); + walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) }); +} + +sub output { + return if $raw; + my ($file, $subname, $pack, $name, $ev, $perfile, $persubname, + $perpack, $pername, $perev); + foreach $file (sort(keys(%table))) { + $perfile = $table{$file}; + print "File $file\n"; + foreach $subname (sort(keys(%$perfile))) { + $persubname = $perfile->{$subname}; + print " Subroutine $subname\n"; + foreach $pack (sort(keys(%$persubname))) { + $perpack = $persubname->{$pack}; + print " Package $pack\n"; + foreach $name (sort(keys(%$perpack))) { + $pername = $perpack->{$name}; + my @lines; + foreach $ev (qw(intro formdef subdef meth subused used)) { + $perev = $pername->{$ev}; + if (defined($perev) && @$perev) { + my $code = $code{$ev}; + push(@lines, map("$code$_", @$perev)); + } + } + printf " %-16s %s\n", $name, join(", ", @lines); + } + } + } + } +} + +sub compile { + my @options = @_; + my ($option, $opt, $arg); + OPTION: + while ($option = shift @options) { + if ($option =~ /^-(.)(.*)/) { + $opt = $1; + $arg = $2; + } else { + unshift @options, $option; + last OPTION; + } + if ($opt eq "-" && $arg eq "-") { + shift @options; + last OPTION; + } elsif ($opt eq "o") { + $arg ||= shift @options; + open(STDOUT, ">$arg") or return "$arg: $!\n"; + } elsif ($opt eq "d") { + $nodefs = 1; + } elsif ($opt eq "r") { + $raw = 1; + } elsif ($opt eq "D") { + $arg ||= shift @options; + foreach $arg (split(//, $arg)) { + if ($arg eq "o") { + B->debug(1); + } elsif ($arg eq "O") { + $debug_op = 1; + } elsif ($arg eq "t") { + $debug_top = 1; + } + } + } + } + if (@options) { + return sub { + my $objname; + xref_definitions(); + foreach $objname (@options) { + $objname = "main::$objname" unless $objname =~ /::/; + eval "xref_object(\\&$objname)"; + die "xref_object(\\&$objname) failed: $@" if $@; + } + output(); + } + } else { + return sub { + xref_definitions(); + xref_main(); + output(); + } + } +} + +1; diff --git a/contrib/perl5/ext/B/B/assemble b/contrib/perl5/ext/B/B/assemble new file mode 100755 index 0000000..43cc5bc --- /dev/null +++ b/contrib/perl5/ext/B/B/assemble @@ -0,0 +1,30 @@ +use B::Assembler qw(assemble_fh); +use FileHandle; + +my ($filename, $fh, $out); + +if ($ARGV[0] eq "-d") { + B::Assembler::debug(1); + shift; +} + +$out = \*STDOUT; + +if (@ARGV == 0) { + $fh = \*STDIN; + $filename = "-"; +} elsif (@ARGV == 1) { + $filename = $ARGV[0]; + $fh = new FileHandle "<$filename"; +} elsif (@ARGV == 2) { + $filename = $ARGV[0]; + $fh = new FileHandle "<$filename"; + $out = new FileHandle ">$ARGV[1]"; +} else { + die "Usage: assemble [filename] [outfilename]\n"; +} + +binmode $out; +$SIG{__WARN__} = sub { warn "$filename:@_" }; +$SIG{__DIE__} = sub { die "$filename: @_" }; +assemble_fh($fh, sub { print $out @_ }); diff --git a/contrib/perl5/ext/B/B/cc_harness b/contrib/perl5/ext/B/B/cc_harness new file mode 100644 index 0000000..79f8727 --- /dev/null +++ b/contrib/perl5/ext/B/B/cc_harness @@ -0,0 +1,12 @@ +use Config; + +$libdir = $ENV{PERL_SRC} || "$Config{installarchlib}/CORE"; + +if (!grep(/^-[cS]$/, @ARGV)) { + $linkargs = sprintf("%s $libdir/$Config{libperl} %s", + @Config{qw(ldflags libs)}); +} + +$cccmd = "$Config{cc} $Config{ccflags} -I$libdir @ARGV $linkargs"; +print "$cccmd\n"; +exec $cccmd; diff --git a/contrib/perl5/ext/B/B/disassemble b/contrib/perl5/ext/B/B/disassemble new file mode 100755 index 0000000..6530b80 --- /dev/null +++ b/contrib/perl5/ext/B/B/disassemble @@ -0,0 +1,22 @@ +use B::Disassembler qw(disassemble_fh); +use FileHandle; + +my $fh; +if (@ARGV == 0) { + $fh = \*STDIN; +} elsif (@ARGV == 1) { + $fh = new FileHandle "<$ARGV[0]"; +} else { + die "Usage: disassemble [filename]\n"; +} + +sub print_insn { + my ($insn, $arg) = @_; + if (defined($arg)) { + printf "%s %s\n", $insn, $arg; + } else { + print $insn, "\n"; + } +} + +disassemble_fh($fh, \&print_insn); diff --git a/contrib/perl5/ext/B/B/makeliblinks b/contrib/perl5/ext/B/B/makeliblinks new file mode 100644 index 0000000..8256078 --- /dev/null +++ b/contrib/perl5/ext/B/B/makeliblinks @@ -0,0 +1,54 @@ +use File::Find; +use Config; + +if (@ARGV != 2) { + warn <<"EOT"; +Usage: makeliblinks libautodir targetdir +where libautodir is the architecture-dependent auto directory +(e.g. $Config::Config{archlib}/auto). +EOT + exit 2; +} + +my ($libautodir, $targetdir) = @ARGV; + +# Calculate relative path prefix from $targetdir to $libautodir +sub relprefix { + my ($to, $from) = @_; + my $up; + for ($up = 0; substr($to, 0, length($from)) ne $from; $up++) { + $from =~ s( + [^/]+ (?# a group of non-slashes) + /* (?# maybe with some trailing slashes) + $ (?# at the end of the path) + )()x; + } + return (("../" x $up) . substr($to, length($from))); +} + +my $relprefix = relprefix($libautodir, $targetdir); + +my ($dlext, $lib_ext) = @Config::Config{qw(dlext lib_ext)}; + +sub link_if_library { + if (/\.($dlext|$lib_ext)$/o) { + my $ext = $1; + my $name = $File::Find::name; + if (substr($name, 0, length($libautodir) + 1) ne "$libautodir/") { + die "directory of $name doesn't match $libautodir\n"; + } + substr($name, 0, length($libautodir) + 1) = ''; + my @parts = split(m(/), $name); + if ($parts[-1] ne "$parts[-2].$ext") { + die "module name $_ doesn't match its directory $libautodir\n"; + } + pop @parts; + my $libpath = "$targetdir/lib" . join("__", @parts) . ".$ext"; + print "$libpath -> $relprefix/$name\n"; + symlink("$relprefix/$name", $libpath) + or warn "above link failed with error: $!\n"; + } +} + +find(\&link_if_library, $libautodir); +exit 0; diff --git a/contrib/perl5/ext/B/Makefile.PL b/contrib/perl5/ext/B/Makefile.PL new file mode 100644 index 0000000..cdcc4ed --- /dev/null +++ b/contrib/perl5/ext/B/Makefile.PL @@ -0,0 +1,46 @@ +use ExtUtils::MakeMaker; +use Config; + +my $e = $Config{'exe_ext'}; +my $o = $Config{'obj_ext'}; +my $exeout_flag = '-o '; +if ($^O eq 'MSWin32') { + if ($Config{'cc'} =~ /^cl/i) { + $exeout_flag = '-Fe'; + } + elsif ($Config{'cc'} =~ /^bcc/i) { + $exeout_flag = '-e'; + } +} + +WriteMakefile( + NAME => "B", + VERSION => "a5", + MAN3PODS => ' ', + clean => { + FILES => "perl$e byteperl$e *$o B.c *~" + } +); + +sub MY::post_constants { + "\nLIBS = $Config{libs}\n" +} + +# Leave out doing byteperl for now. Probably should be built in the +# core directory or somewhere else rather than here +#sub MY::top_targets { +# my $self = shift; +# my $targets = $self->MM::top_targets(); +# $targets =~ s/^(all ::.*)$/$1 byteperl$e/m; +# return <<"EOT" . $targets; + +# +# byteperl is *not* a standard perl+XSUB executable. It's a special +# program for running standalone bytecode executables. It isn't an XSUB +# at the moment because a standlone Perl program needs to set up curpad +# which is overwritten on exit from an XSUB. +# +#byteperl$e : byteperl$o B$o \$(PERL_SRC)/byterun$o +# \$(CC) ${exeout_flag}byteperl$e byteperl$o B$o byterun$o \$(LDFLAGS) \$(PERL_ARCHLIB)/CORE/$Config{libperl} \$(LIBS) +#EOT +#} diff --git a/contrib/perl5/ext/B/NOTES b/contrib/perl5/ext/B/NOTES new file mode 100644 index 0000000..ee10ba0 --- /dev/null +++ b/contrib/perl5/ext/B/NOTES @@ -0,0 +1,168 @@ +C backend invocation + If there are any non-option arguments, they are taken to be + names of objects to be saved (probably doesn't work properly yet). + Without extra arguments, it saves the main program. + -ofilename Output to filename instead of STDOUT + -v Verbose (currently gives a few compilation statistics) + -- Force end of options + -uPackname Force apparently unused subs from package Packname to + be compiled. This allows programs to use eval "foo()" + even when sub foo is never seen to be used at compile + time. The down side is that any subs which really are + never used also have code generated. This option is + necessary, for example, if you have a signal handler + foo which you initialise with $SIG{BAR} = "foo". + A better fix, though, is just to change it to + $SIG{BAR} = \&foo. You can have multiple -u options. + -D Debug options (concat or separate flags like perl -D) + o OPs, prints each OP as it's processed + c COPs, prints COPs as processed (incl. file & line num) + A prints AV information on saving + C prints CV information on saving + M prints MAGIC information on saving + -f Force optimisations on or off one at a time. + cog Copy-on-grow: PVs declared and initialised statically + no-cog No copy-on-grow + -On Optimisation level (n = 0, 1, 2, ...). -O means -O1. + Currently, -O1 and higher set -fcog. + +Examples + perl -MO=C foo.pl > foo.c + perl cc_harness -o foo foo.c + + perl -MO=C,-v,-DcA bar.pl > /dev/null + +CC backend invocation + If there are any non-option arguments, they are taken to be names of + subs to be saved. Without extra arguments, it saves the main program. + -ofilename Output to filename instead of STDOUT + -- Force end of options + -uPackname Force apparently unused subs from package Packname to + be compiled. This allows programs to use eval "foo()" + even when sub foo is never seen to be used at compile + time. The down side is that any subs which really are + never used also have code generated. This option is + necessary, for example, if you have a signal handler + foo which you initialise with $SIG{BAR} = "foo". + A better fix, though, is just to change it to + $SIG{BAR} = \&foo. You can have multiple -u options. + -mModulename Instead of generating source for a runnable executable, + generate source for an XSUB module. The + boot_Modulename function (which DynaLoader can look + for) does the appropriate initialisation and runs the + main part of the Perl source that is being compiled. + -pn Generate code for perl patchlevel n (e.g. 3 or 4). + The default is to generate C code which will link + with the currently executing version of perl. + running the perl compiler. + -D Debug options (concat or separate flags like perl -D) + r Writes debugging output to STDERR just as it's about + to write to the program's runtime (otherwise writes + debugging info as comments in its C output). + O Outputs each OP as it's compiled + s Outputs the contents of the shadow stack at each OP + p Outputs the contents of the shadow pad of lexicals as + it's loaded for each sub or the main program. + q Outputs the name of each fake PP function in the queue + as it's about to processes. + l Output the filename and line number of each original + line of Perl code as it's processed (pp_nextstate). + t Outputs timing information of compilation stages + -f Force optimisations on or off one at a time. + [ + cog Copy-on-grow: PVs declared and initialised statically + no-cog No copy-on-grow + These two not in CC yet. + ] + freetmps-each-bblock Delays FREETMPS from the end of each + statement to the end of the each basic + block. + freetmps-each-loop Delays FREETMPS from the end of each + statement to the end of the group of + basic blocks forming a loop. At most + one of the freetmps-each-* options can + be used. + omit-taint Omits generating code for handling + perl's tainting mechanism. + -On Optimisation level (n = 0, 1, 2, ...). -O means -O1. + Currently, -O1 sets -ffreetmps-each-bblock and -O2 + sets -ffreetmps-each-loop. + +Example + perl -MO=CC,-O2,-ofoo.c foo.pl + perl cc_harness -o foo foo.c + + perl -MO=CC,-mFoo,-oFoo.c Foo.pm + perl cc_harness -shared -c -o Foo.so Foo.c + + +Bytecode backend invocation + + If there are any non-option arguments, they are taken to be + names of objects to be saved (probably doesn't work properly yet). + Without extra arguments, it saves the main program. + -ofilename Output to filename instead of STDOUT. + -- Force end of options. + -f Force optimisations on or off one at a time. + Each can be preceded by no- to turn the option off. + compress-nullops + Only fills in the necessary fields of ops which have + been optimised away by perl's internal compiler. + omit-sequence-numbers + Leaves out code to fill in the op_seq field of all ops + which is only used by perl's internal compiler. + bypass-nullops + If op->op_next ever points to a NULLOP, replaces the + op_next field with the first non-NULLOP in the path + of execution. + strip-syntax-tree + Leaves out code to fill in the pointers which link the + internal syntax tree together. They're not needed at + run-time but leaving them out will make it impossible + to recompile or disassemble the resulting program. + It will also stop "goto label" statements from working. + -On Optimisation level (n = 0, 1, 2, ...). -O means -O1. + -O1 sets -fcompress-nullops -fomit-sequence numbers. + -O6 adds -fstrip-syntax-tree. + -D Debug options (concat or separate flags like perl -D) + o OPs, prints each OP as it's processed. + b print debugging information about bytecompiler progress + a tells the assembler to include source assembler lines + in its output as bytecode comments. + C prints each CV taken from the final symbol tree walk. + -S Output assembler source rather than piping it + through the assembler and outputting bytecode. + -m Compile as a module rather than a standalone program. + Currently this just means that the bytecodes for + initialising main_start, main_root and curpad are + omitted. + +Example + perl -MO=Bytecode,-O6,-o,foo.plc foo.pl + + perl -MO=Bytecode,-S foo.pl > foo.S + assemble foo.S > foo.plc + byteperl foo.plc + + perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm + +Backends for debugging + perl -MO=Terse,exec foo.pl + perl -MO=Debug bar.pl + +O module + Used with "perl -MO=Backend,foo,bar prog.pl" to invoke the backend + B::Backend with options foo and bar. O invokes the sub + B::Backend::compile() with arguments foo and bar at BEGIN time. + That compile() sub must do any inital argument processing replied. + If unsuccessful, it should return a string which O arranges to be + printed as an error message followed by a clean error exit. In the + normal case where any option processing in compile() is successful, + it should return a sub ref (usually a closure) to perform the + actual compilation. When O regains control, it ensures that the + "-c" option is forced (so that the program being compiled doesn't + end up running) and registers an END block to call back the sub ref + returned from the backend's compile(). Perl then continues by + parsing prog.pl (just as it would with "perl -c prog.pl") and after + doing so, assuming there are no parse-time errors, the END block + of O gets called and the actual backend compilation happens. Phew. diff --git a/contrib/perl5/ext/B/O.pm b/contrib/perl5/ext/B/O.pm new file mode 100644 index 0000000..ad391a3 --- /dev/null +++ b/contrib/perl5/ext/B/O.pm @@ -0,0 +1,85 @@ +package O; +use B qw(minus_c); +use Carp; + +sub import { + my ($class, $backend, @options) = @_; + eval "use B::$backend ()"; + if ($@) { + croak "use of backend $backend failed: $@"; + } + my $compilesub = &{"B::${backend}::compile"}(@options); + if (ref($compilesub) eq "CODE") { + minus_c; + eval 'END { &$compilesub() }'; + } else { + die $compilesub; + } +} + +1; + +__END__ + +=head1 NAME + +O - Generic interface to Perl Compiler backends + +=head1 SYNOPSIS + + perl -MO=Backend[,OPTIONS] foo.pl + +=head1 DESCRIPTION + +This is the module that is used as a frontend to the Perl Compiler. + +=head1 CONVENTIONS + +Most compiler backends use the following conventions: OPTIONS +consists of a comma-separated list of words (no white-space). +The C<-v> option usually puts the backend into verbose mode. +The C<-ofile> option generates output to B instead of +stdout. The C<-D> option followed by various letters turns on +various internal debugging flags. See the documentation for the +desired backend (named C for the example above) to +find out about that backend. + +=head1 IMPLEMENTATION + +This section is only necessary for those who want to write a +compiler backend module that can be used via this module. + +The command-line mentioned in the SYNOPSIS section corresponds to +the Perl code + + use O ("Backend", OPTIONS); + +The C function which that calls loads in the appropriate +C module and calls the C function in that +package, passing it OPTIONS. That function is expected to return +a sub reference which we'll call CALLBACK. Next, the "compile-only" +flag is switched on (equivalent to the command-line option C<-c>) +and an END block is registered which calls CALLBACK. Thus the main +Perl program mentioned on the command-line is read in, parsed and +compiled into internal syntax tree form. Since the C<-c> flag is +set, the program does not start running (excepting BEGIN blocks of +course) but the CALLBACK function registered by the compiler +backend is called. + +In summary, a compiler backend module should be called "B::Foo" +for some foo and live in the appropriate directory for that name. +It should define a function called C. When the user types + + perl -MO=Foo,OPTIONS foo.pl + +that function is called and is passed those OPTIONS (split on +commas). It should return a sub ref to the main compilation function. +After the user's program is loaded and parsed, that returned sub ref +is invoked which can then go ahead and do the compilation, usually by +making use of the C module's functionality. + +=head1 AUTHOR + +Malcolm Beattie, C + +=cut diff --git a/contrib/perl5/ext/B/README b/contrib/perl5/ext/B/README new file mode 100644 index 0000000..4e4ed25 --- /dev/null +++ b/contrib/perl5/ext/B/README @@ -0,0 +1,325 @@ + Perl Compiler Kit, Version alpha4 + + Copyright (c) 1996, 1997, Malcolm Beattie + + This program is free software; you can redistribute it and/or modify + it under the terms of either: + + a) the GNU General Public License as published by the Free + Software Foundation; either version 1, or (at your option) any + later version, or + + b) the "Artistic License" which comes with this kit. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either + the GNU General Public License or the Artistic License for more details. + + You should have received a copy of the Artistic License with this kit, + in the file named "Artistic". If not, you can get one from the Perl + distribution. You should also have received a copy of the GNU General + Public License, in the file named "Copying". If not, you can get one + from the Perl distribution or else write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +CHANGES + +New since alpha3 + Anonymous subs work properly with C and CC. + Heuristics for forcing compilation of apparently unused subs/methods. + Subs which use the AutoLoader module are forcibly loaded at compile-time. + Slightly faster compilation. + Handles slightly more complex code within a BEGIN { }. + Minor bug fixes. + +New since alpha2 + CC backend now supports ".." and s//e. + Xref backend generates cross-reference reports + Cleanups to fix benign but irritating "-w" warnings + Minor cxstack fix +New since alpha1 + Working CC backend + Shared globs and pre-initialised hash support + Some XSUB support + Assorted bug fixes + +INSTALLATION + +(1) You need perl5.002 or later. + +(2) If you want to compile and run programs with the C or CC backends +which undefine (or redefine) subroutines, then you need to apply a +one-line patch to perl itself. One or two of the programs in perl's +own test suite do this. The patch is in file op.patch. It prevents +perl from calling free() on OPs with the magic sequence number (U16)-1. +The compiler declares all OPs as static structures and uses that magic +sequence number. + +(3) Type + perl Makefile.PL +to write a personalised Makefile for your system. If you want the +bytecode modules to support reading bytecode from strings (instead of +just from files) then add the option + -DINDIRECT_BGET_MACROS +into the middle of the definition of the CCCMD macro in the Makefile. +Your C compiler may need to be able to cope with Standard C for this. +I haven't tested this option yet with an old pre-Standard compiler. + +(4) If your platform supports dynamic loading then just type + make +and you can then use + perl -Iblib/arch -MO=foo bar +to use the compiler modules (see later for details). +If you need/want instead to make a statically linked perl which +contains the appropriate modules, then type + make perl + make byteperl +and you can then use + ./perl -MO=foo bar +to use the compiler modules. +In both cases, the byteperl executable is required for running standalone +bytecode programs. It is *not* a standard perl+XSUB perl executable. + +USAGE + +As of the alpha3 release, the Bytecode, C and CC backends are now all +functional enough to compile almost the whole of the main perl test +suite. In the case of the CC backend, any failures are all due to +differences and/or known bugs documented below. See the file TESTS. +In the following examples, you'll need to replace "perl" by + perl -Iblib/arch +if you have built the extensions for a dynamic loading platform but +haven't installed the extensions completely. You'll need to replace +"perl" by + ./perl +if you have built the extensions into a statically linked perl binary. + +(1) To compile perl program foo.pl with the C backend, do + perl -MO=C,-ofoo.c foo.pl +Then use the cc_harness perl program to compile the resulting C source: + perl cc_harness -O2 -o foo foo.c + +If you are using a non-ANSI pre-Standard C compiler that can't handle +pre-declaring static arrays, then add -DBROKEN_STATIC_REDECL to the +options you use: + perl cc_harness -O2 -o foo -DBROKEN_STATIC_REDECL foo.c +If you are using a non-ANSI pre-Standard C compiler that can't handle +static initialisation of structures with union members then add +-DBROKEN_UNION_INIT to the options you use. If you want command line +arguments passed to your executable to be interpreted by perl (e.g. -Dx) +then compile foo.c with -DALLOW_PERL_OPTIONS. Otherwise, all command line +arguments passed to foo will appear directly in @ARGV. The resulting +executable foo is the compiled version of foo.pl. See the file NOTES for +extra options you can pass to -MO=C. + +There are some constraints on the contents on foo.pl if you want to be +able to compile it successfully. Some problems can be fixed fairly easily +by altering foo.pl; some problems with the compiler are known to be +straightforward to solve and I'll do so soon. The file Todo lists a +number of known problems. See the XSUB section lower down for information +about compiling programs which use XSUBs. + +(2) To compile foo.pl with the CC backend (which generates actual +optimised C code for the execution path of your perl program), use + perl -MO=CC,-ofoo.c foo.pl + +and proceed just as with the C backend. You should almost certainly +use an option such as -O2 with the subsequent cc_harness invocation +so that your C compiler uses optimisation. The C code generated by +the Perl compiler's CC backend looks ugly to humans but is easily +optimised by C compilers. + +To make the most of this compiler backend, you need to tell the +compiler when you're using int or double variables so that it can +optimise appropriately (although this part of the compiler is the most +buggy). You currently do that by naming lexical variables ending in +"_i" for ints, "_d" for doubles, "_ir" for int "register" variables or +"_dr" for double "register" variables. Here "register" is a promise +that you won't pass a reference to the variable into a sub which then +modifies the variable. The compiler ought to catch attempts to use +"\$i" just as C compilers catch attempts to do "&i" for a register int +i but it doesn't at the moment. Bugs in the CC backend may make your +program fail in mysterious ways and give wrong answers rather than just +crash in boring ways. But, hey, this is an alpha release so you knew +that anyway. See the XSUB section lower down for information about +compiling programs which use XSUBs. + +If your program uses classes which define methods (or other subs which +are not exported and not apparently used until runtime) then you'll +need to use -u compile-time options (see the NOTES file) to force the +subs to be compiled. Future releases will probably default the other +way, do more auto-detection and provide more fine-grained control. + +Since compiled executables need linking with libperl, you may want +to turn libperl.a into a shared library if your platform supports +it. For example, with Digital UNIX, do something like + ld -shared -o libperl.so -all libperl.a -none -lc +and with Linux/ELF, rebuild the perl .c files with -fPIC (and I +also suggest -fomit-frame-pointer for Linux on Intel architetcures), +do "make libperl.a" and then do + gcc -shared -Wl,-soname,libperl.so.5 -o libperl.so.5.3 `ar t libperl.a` +and then + # cp libperl.so.5.3 /usr/lib + # cd /usr/lib + # ln -s libperl.so.5.3 libperl.so.5 + # ln -s libperl.so.5 libperl.so + # ldconfig +When you compile perl executables with cc_harness, append -L/usr/lib +otherwise the -L for the perl source directory will override it. For +example, + perl -Iblib/arch -MO=CC,-O2,-ofoo3.c foo3.bench + perl cc_harness -o foo3 -O2 foo3.c -L/usr/lib + ls -l foo3 + -rwxr-xr-x 1 mbeattie xzdg 11218 Jul 1 15:28 foo3 +You'll probably also want to link your main perl executable against +libperl.so; it's nice having an 11K perl executable. + +(3) To compile foo.pl into bytecode do + perl -MO=Bytecode,-ofoo foo.pl +To run the resulting bytecode file foo as a standalone program, you +use the program byteperl which should have been built along with the +extensions. + ./byteperl foo +Any extra arguments are passed in as @ARGV; they are not interpreted +as perl options. If you want to load chunks of bytecode into an already +running perl program then use the -m option and investigate the +byteload_fh and byteload_string functions exported by the B module. +See the NOTES file for details of these and other options (including +optimisation options and ways of getting at the intermediate "assembler" +code that the Bytecode backend uses). + +(3) There are little Bourne shell scripts and perl programs to aid with +some common operations: assemble, disassemble, run_bytecode_test, +run_test, cc_harness, test_harness, test_harness_bytecode. + +(4) Walk the op tree in execution order printing terse info about each op + perl -MO=Terse,exec foo.pl + +(5) Walk the op tree in syntax order printing lengthier debug info about +each op. You can also append ",exec" to walk in execution order, but the +formatting is designed to look nice with Terse rather than Debug. + perl -MO=Debug foo.pl + +(6) Produce a cross-reference report of the line numbers at which all +variables, subs and formats are defined and used. + perl -MO=Xref foo.pl + +XSUBS + +The C and CC backends can successfully compile some perl programs which +make use of XSUB extensions. [I'll add more detail to this section in a +later release.] As a prerequisite, such extensions must not need to do +anything in their BOOT: section which needs to be done at runtime rather +than compile time. Normally, the only code in the boot_Foo() function is +a list of newXS() calls which xsubpp puts there and the compiler handles +saving those XS subs itself. For each XSUB used, the C and CC compiler +will generate an initialiser in their C output which refers to the name +of the relevant C function (XS_Foo_somesub). What is not yet automated +is the necessary commands and cc command-line options (e.g. via +"perl cc_harness") which link against the extension libraries. For now, +you need the XSUB extension to have installed files in the right format +for using as C libraries (e.g. Foo.a or Foo.so). As the Foo.so files (or +your platform's version) aren't suitable for linking against, you will +have to reget the extension source and rebuild it as a static extension +to force the generation of a suitable Foo.a file. Then you need to make +a symlink (or copy or rename) of that file into a libFoo.a suitable for +cc linking. Then add the appropriate -L and -l options to your +"perl cc_harness" command line to find and link against those libraries. +You may also need to fix up some platform-dependent environment variable +to ensure that linked-against .so files are found at runtime too. + +DIFFERENCES + +The result of running a compiled Perl program can sometimes be different +from running the same program with standard perl. Think of the compiler +as having a slightly different implementation of the language Perl. +Unfortunately, since Perl has had a single implementation until now, +there are no formal standards or documents defining what behaviour is +guaranteed of Perl the language and what just "happens to work". +Some of the differences below are almost impossible to change because of +the way the compiler works. Others can be changed to produce "standard" +perl behaviour if it's deemed proper and the resulting performance hit +is accepted. I'll use "standard perl" to mean the result of running a +Perl program using the perl executable from the perl distribution. +I'll use "compiled Perl program" to mean running an executable produced +by this compiler kit ("the compiler") with the CC backend. + +Loops + Standard perl calculates the target of "next", "last", and "redo" + at run-time. The compiler calculates the targets at compile-time. + For example, the program + + sub skip_on_odd { next NUMBER if $_[0] % 2 } + NUMBER: for ($i = 0; $i < 5; $i++) { + skip_on_odd($i); + print $i; + } + + produces the output + 024 + with standard perl but gives a compile-time error with the compiler. + +Context of ".." + The context (scalar or array) of the ".." operator determines whether + it behaves as a range or a flip/flop. Standard perl delays until + runtime the decision of which context it is in but the compiler needs + to know the context at compile-time. For example, + @a = (4,6,1,0,0,1); + sub range { (shift @a)..(shift @a) } + print range(); + while (@a) { print scalar(range()) } + generates the output + 456123E0 + with standard Perl but gives a compile-time error with compiled Perl. + +Arithmetic + Compiled Perl programs use native C arithemtic much more frequently + than standard perl. Operations on large numbers or on boundary + cases may produce different behaviour. + +Deprecated features + Features of standard perl such as $[ which have been deprecated + in standard perl since version 5 was released have not been + implemented in the compiler. + +Others + I'll add to this list as I remember what they are. + +BUGS + +Here are some things which may cause the compiler problems. + +The following render the compiler useless (without serious hacking): +* Use of the DATA filehandle (via __END__ or __DATA__ tokens) +* Operator overloading with %OVERLOAD +* The (deprecated) magic array-offset variable $[ does not work +* The following operators are not yet implemented for CC + goto + sort with a non-default comparison (i.e. a named sub or inline block) +* You can't use "last" to exit from a non-loop block. + +The following may give significant problems: +* BEGIN blocks containing complex initialisation code +* Code which is only ever referred to at runtime (e.g. via eval "..." or + via method calls): see the -u option for the C and CC backends. +* Run-time lookups of lexical variables in "outside" closures + +The following may cause problems (not thoroughly tested): +* Dependencies on whether values of some "magic" Perl variables are + determined at compile-time or runtime. +* For the C and CC backends: compile-time strings which are longer than + your C compiler can cope with in a single line or definition. +* Reliance on intimate details of global destruction +* For the Bytecode backend: high -On optimisation numbers with code + that has complex flow of control. +* Any "-w" option in the first line of your perl program is seen and + acted on by perl itself before the compiler starts. The compiler + itself then runs with warnings turned on. This may cause perl to + print out warnings about the compiler itself since I haven't tested + it thoroughly with warnings turned on. + +There is a terser but more complete list in the Todo file. + +Malcolm Beattie +2 September 1996 diff --git a/contrib/perl5/ext/B/TESTS b/contrib/perl5/ext/B/TESTS new file mode 100644 index 0000000..e050f6c --- /dev/null +++ b/contrib/perl5/ext/B/TESTS @@ -0,0 +1,78 @@ +Test results from compiling t/*/*.t + C Bytecode CC + +base/cond.t OK ok OK +base/if.t OK ok OK +base/lex.t OK ok OK +base/pat.t OK ok OK +base/term.t OK ok OK +cmd/elsif.t OK ok OK +cmd/for.t OK ok ok 1, 2, 3, panic: pp_iter +cmd/mod.t OK ok ok +cmd/subval.t OK ok 1..34, not ok 27,28 (simply + because filename changes). +cmd/switch.t OK ok ok +cmd/while.t OK ok ok +io/argv.t OK ok ok +io/dup.t OK ok ok +io/fs.t OK ok ok +io/inplace.t OK ok ok +io/pipe.t OK ok ok with -umain +io/print.t OK ok ok +io/tell.t OK ok ok +op/append.t OK ok OK +op/array.t OK ok 1..36, not ok 7,10 (no $[) +op/auto.t OK ok OK +op/chop.t OK ok OK +op/cond.t OK ok OK +op/delete.t OK ok OK +op/do.t OK ok OK +op/each.t OK ok OK +op/eval.t OK ok ok 1-6 of 16 then exits +op/exec.t OK ok OK +op/exp.t OK ok OK +op/flip.t OK ok OK +op/fork.t OK ok OK +op/glob.t OK ok OK +op/goto.t OK ok 1..9, Can't find label label1. +op/groups.t OK (s/ucb/bin/ under Linux) OK 1..0 for now. +op/index.t OK ok OK +op/int.t OK ok OK +op/join.t OK ok OK +op/list.t OK ok OK +op/local.t OK ok OK +op/magic.t OK ok OK +op/misc.t no DATA filehandle so succeeds trivially with 1..0 +op/mkdir.t OK ok OK +op/my.t OK ok OK +op/oct.t OK ok OK (C large const warnings) +op/ord.t OK ok OK +op/overload.t Mostly not ok Mostly not ok C errors. +op/pack.t OK ok OK +op/pat.t omit 26 (reset) ok [lots of memory for compile] +op/push.t OK ok OK +op/quotemeta.t OK ok OK +op/rand.t OK ok +op/range.t OK ok OK +op/read.t OK ok OK +op/readdir.t OK ok OK (substcont works too) +op/ref.t omits "ok 40" (lex destruction) ok (Bytecode) + CC: need -u for OBJ,BASEOBJ, + UNIVERSAL,WHATEVER,main. + 1..41, ok1-33,36-38, + then ok 41, ok 39.DESTROY probs +op/regexp.t OK ok ok (trivially all eval'd) +op/repeat.t OK ok ok +op/sleep.t OK ok ok +op/sort.t OK ok 1..10, ok 1, Out of memory! +op/split.t OK ok ok +op/sprintf.t OK ok ok +op/stat.t OK ok ok +op/study.t OK ok ok +op/subst.t OK ok ok +op/substr.t OK ok ok1-22 except 7-9,11 (all $[) +op/time.t OK ok ok +op/undef.t omit 21 ok ok +op/unshift.t OK ok ok +op/vec.t OK ok ok +op/write.t not ok 3 (no CvOUTSIDE lex from runtime eval). CC: 1..3, hang diff --git a/contrib/perl5/ext/B/Todo b/contrib/perl5/ext/B/Todo new file mode 100644 index 0000000..495be2e --- /dev/null +++ b/contrib/perl5/ext/B/Todo @@ -0,0 +1,37 @@ +* Fixes + +CC backend: goto, sort with non-default comparison. last for non-loop blocks. +Version checking +improve XSUB handling (both static and dynamic) +sv_magic can do SvREFCNT_inc(obj) which messes up precalculated refcounts +allocation of XPV[INAHC]V structures needs fixing: Perl tries to free +them whereas the compiler expects them to be linked to a xpv[inahc]v_root +list the same as X[IPR]V structures. +ref counts +perl_parse replacement +fix cstring for long strings +compile-time initialisation of AvARRAYs +signed/unsigned problems with NV (and IV?) initialisation and elsewhere? +CvOUTSIDE for ordinary subs +DATA filehandle for standalone Bytecode program (easy) +DATA filehandle for multiple bytecode-compiled modules (harder) +DATA filehandle for C-compiled program (yet harder) + +* Features + +type checking +compile time v. runtime initialisation +save PMOPs in compiled form +selection of what to dump +options for cutting out line info etc. +comment output +shared constants +module dependencies + +* Optimisations +collapse LISTOPs to UNOPs or BASEOPs +compile-time qw(), constant subs +global analysis of variables, type hints etc. +demand-loaded bytecode (leader of each basic block replaced by an op +which loads in bytecode for its block) +fast sub calls for CC backend diff --git a/contrib/perl5/ext/B/byteperl.c b/contrib/perl5/ext/B/byteperl.c new file mode 100644 index 0000000..6b53e3b --- /dev/null +++ b/contrib/perl5/ext/B/byteperl.c @@ -0,0 +1,110 @@ +#include "EXTERN.h" +#include "perl.h" +#ifndef PATCHLEVEL +#include "patchlevel.h" +#endif + +static void xs_init _((void)); +static PerlInterpreter *my_perl; + +int +#ifndef CAN_PROTOTYPE +main(argc, argv, env) +int argc; +char **argv; +char **env; +#else /* def(CAN_PROTOTYPE) */ +main(int argc, char **argv, char **env) +#endif /* def(CAN_PROTOTYPE) */ +{ + int exitstatus; + int i; + char **fakeargv; + FILE *fp; +#ifdef INDIRECT_BGET_MACROS + struct bytestream bs; +#endif /* INDIRECT_BGET_MACROS */ + + INIT_SPECIALSV_LIST; + PERL_SYS_INIT(&argc,&argv); + +#if PATCHLEVEL > 3 || (PATCHLEVEL == 3 && SUBVERSION >= 1) + perl_init_i18nl10n(1); +#else + perl_init_i18nl14n(1); +#endif + + if (!PL_do_undump) { + my_perl = perl_alloc(); + if (!my_perl) +#ifdef VMS + exit(vaxc$errno); +#else + exit(1); +#endif + perl_construct( my_perl ); + } + +#ifdef CSH + if (!PL_cshlen) + PL_cshlen = strlen(PL_cshname); +#endif + + if (argc < 2) + fp = stdin; + else { +#ifdef WIN32 + fp = fopen(argv[1], "rb"); +#else + fp = fopen(argv[1], "r"); +#endif + if (!fp) { + perror(argv[1]); +#ifdef VMS + exit(vaxc$errno); +#else + exit(1); +#endif + } + argv++; + argc--; + } + New(666, fakeargv, argc + 4, char *); + fakeargv[0] = argv[0]; + fakeargv[1] = "-e"; + fakeargv[2] = ""; + fakeargv[3] = "--"; + for (i = 1; i < argc; i++) + fakeargv[i + 3] = argv[i]; + fakeargv[argc + 3] = 0; + + exitstatus = perl_parse(my_perl, xs_init, argc + 3, fakeargv, NULL); + if (exitstatus) + exit( exitstatus ); + + sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]); + PL_main_cv = PL_compcv; + PL_compcv = 0; + +#ifdef INDIRECT_BGET_MACROS + bs.data = fp; + bs.fgetc = (int(*) _((void*)))fgetc; + bs.fread = (int(*) _((char*,size_t,size_t,void*)))fread; + bs.freadpv = freadpv; + byterun(bs); +#else + byterun(fp); +#endif /* INDIRECT_BGET_MACROS */ + + exitstatus = perl_run( my_perl ); + + perl_destruct( my_perl ); + perl_free( my_perl ); + + exit( exitstatus ); +} + +static void +xs_init() +{ +} diff --git a/contrib/perl5/ext/B/ramblings/cc.notes b/contrib/perl5/ext/B/ramblings/cc.notes new file mode 100644 index 0000000..47bd65a --- /dev/null +++ b/contrib/perl5/ext/B/ramblings/cc.notes @@ -0,0 +1,32 @@ +At entry to each basic block, the following can be assumed (and hence +must be forced where necessary at the end of each basic block): + +The shadow stack @stack is empty. +For each lexical object in @pad, VALID_IV holds for each T_INT, +VALID_DOUBLE holds for each T_DOUBLE and VALID_SV holds otherwise. +The C shadow variable sp holds the stack pointer (not necessarily stack_sp). + +write_back_stack + Writes the contents of the shadow stack @stack back to the real stack. + A write-back of each object in the stack is forced so that its + backing SV contains the right value and that SV is then pushed onto the + real stack. On return, @stack is empty. + +write_back_lexicals + Forces a write-back (i.e. achieves VALID_SV), where necessary, for each + lexical object in @pad. Objects with the TEMPORARY flag are skipped. If + write_back_lexicals is called with an (optional) argument, then it is + taken to be a bitmask of more flags: any lexical object with one of those + flags set is also skipped and not written back to its SV. + +invalidate_lexicals($avoid) + The VALID_INT and VALID_DOUBLE flags are turned off for each lexical + object in @pad whose flags field doesn't overlap with $avoid. + +reload_lexicals + For each necessary lexical object in @pad, makes sure that VALID_IV + holds for objects of type T_INT, VALID_DOUBLE holds for objects for + type T_DOUBLE, and VALID_SV holds for other objects. An object is + considered for reloading if its flags field does not overlap with the + (optional) argument passed to reload_lexicals. + diff --git a/contrib/perl5/ext/B/ramblings/curcop.runtime b/contrib/perl5/ext/B/ramblings/curcop.runtime new file mode 100644 index 0000000..9b8b7d5 --- /dev/null +++ b/contrib/perl5/ext/B/ramblings/curcop.runtime @@ -0,0 +1,39 @@ +PP code uses of curcop +---------------------- + +pp_rv2gv + when a new glob is created for an OPpLVAL_INTRO, + curcop->cop_line is stored as GvLINE() in the new GP. +pp_bless + curcop->cop_stash is used as the stash in the one-arg form of bless + +pp_repeat + tests (curcop != &compiling) to warn "Can't x= to readonly value" + +pp_pos +pp_substr +pp_index +pp_rindex +pp_aslice +pp_lslice +pp_splice + curcop->cop_arybase + +pp_sort + curcop->cop_stash used to determine whether to gv_fetchpv $a and $b + +pp_caller + tests (curcop->cop_stash == debstash) to determine whether + to set DB::args + +pp_reset + resets vars in curcop->cop_stash + +pp_dbstate + sets curcop = (COP*)op + +doeval + compiles into curcop->cop_stash + +pp_nextstate + sets curcop = (COP*)op diff --git a/contrib/perl5/ext/B/ramblings/flip-flop b/contrib/perl5/ext/B/ramblings/flip-flop new file mode 100644 index 0000000..183d541 --- /dev/null +++ b/contrib/perl5/ext/B/ramblings/flip-flop @@ -0,0 +1,51 @@ +PP(pp_range) +{ + if (GIMME == G_ARRAY) + return cCONDOP->op_true; + return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true; +} + +pp_range is a CONDOP. +In array context, it just returns op_true. +In scalar context it checks the truth of targ and returns +op_false if true, op_true if false. + +flip is an UNOP. +It "looks after" its child which is always a pp_range CONDOP. +In array context, it just returns the child's op_false. +In scalar context, there are three possible outcomes: + (1) set child's targ to 1, our targ to 1 and return op_next. + (2) set child's targ to 1, our targ to 0, sp-- and return child's op_false. + (3) Blank targ and TOPs and return op_next. +Case 1 happens for a "..." with a matching lineno... or true TOPs. +Case 2 happens for a ".." with a matching lineno... or true TOPs. +Case 3 happens for a non-matching lineno or false TOPs. + + $a = lhs..rhs; + + ,-------> range + ^ / \ + | true/ \false + | / \ + first| lhs rhs + | \ first / + ^--- flip <----- flop + \ / + \ / + sassign + + +/* range */ +if (SvTRUE(curpad[op->op_targ])) + goto label(op_false); +/* op_true */ +... +/* flip */ +/* For "..." returns op_next. For ".." returns op_next or op_first->op_false */ +/* end of basic block */ +goto out; +label(range op_false): +... +/* flop */ +out: +... diff --git a/contrib/perl5/ext/B/ramblings/magic b/contrib/perl5/ext/B/ramblings/magic new file mode 100644 index 0000000..e41930a --- /dev/null +++ b/contrib/perl5/ext/B/ramblings/magic @@ -0,0 +1,93 @@ +sv_magic() +---------- +av.c +av_store() + Storing a non-undef element into an SMAGICAL array, av, + assigns the equivalent lowercase form of magic (of the first + MAGIC in the chain) to the value (with obj = av, name = 0 and + namlen = array index). + +gv.c +gv_init() + Initialising gv assigns '*' magic to it with obj = gv, name = + GvNAME and namlen = GvNAMELEN. +gv_fetchpv() + @ISA gets 'I' magic with obj = gv, zero name and namlen. + %OVERLOAD gets 'A' magic with obj = gv, zero name and namlen. + $1 to $9, $&, $`, $', $+ get '\0' magic with obj = gv, + name = GvNAME and namlen = len ( = 1 presumably). +Gv_AMupdate() + Stashes for overload magic seem to get 'c' magic with obj = 0, + name = &amt and namlen = sizeof(amt). +hv_magic(hv, gv, how) + Gives magic how to hv with obj = gv and zero name and namlen. + +mg.c +mg_copy(sv, nsv, key, klen) + Traverses the magic chain of sv. Upper case forms of magic + (only) are copied across to nsv, preserving obj but using + name = key and namlen = klen. +magic_setpos() + LvTARG of a PVLV gets 'g' magic with obj = name = 0 and namlen = pos. + +op.c +mod() + PVLV operators give magic to their targs with + obj = name = namlen = 0. OP_POS gives '.', OP_VEC gives 'v' + and OP_SUBSTR gives 'x'. + +perl.c +magicname(sym, name, namlen) + Fetches/creates a GV with name sym and gives it '\0' magic + with obj = gv, name and namlen as passed. +init_postdump_symbols() + Elements of the environment get given SVs with 'e' magic. + obj = sv and name and namlen point to the actual string + within env. + +pp.c +pp_av2arylen() + $#foo gives '#' magic to the new SV with obj = av and + name = namlen = 0. +pp_study() + SV gets 'g' magic with obj = name = namlen = 0. +pp_substr() + PVLV gets 'x' magic with obj = name = namlen = 0. +pp_vec() + PVLV gets 'x' magic with obj = name = namlen = 0. + +pp_hot.c +pp_match() + m//g gets 'g' magic with obj = name = namlen = 0. + +pp_sys.c +pp_tie() + sv gets magic with obj = sv and name = namlen = 0. + If an HV or an AV, it gets 'P' magic, otherwise 'q' magic. +pp_dbmopen() + 'P' magic for the HV just as with pp_tie(). +pp_sysread() + If tainting, the buffer SV gets 't' magic with + obj = name = namlen = 0. + +sv.c +sv_setsv() + Doing sv_setsv(dstr, gv) gives '*' magic to dstr with + obj = dstr, name = GvNAME, namlen = GvNAMELEN. + +util.c +fbm_compile() + The PVBM gets 'B' magic with obj = name = namlen = 0 and SvVALID + is set to indicate that the Boyer-Moore table is valid. + magic_setbm() just clears the SvVALID flag. + +hv_magic() +---------- + +gv.c +gv_fetchfile() + With perldb, the HV of a gvfile gv gets 'L' magic with obj = gv. +gv_fetchpv() + %SIG gets 'S' magic with obj = siggv. +init_postdump_symbols() + %ENV gets 'E' magic with obj = envgv. diff --git a/contrib/perl5/ext/B/ramblings/reg.alloc b/contrib/perl5/ext/B/ramblings/reg.alloc new file mode 100644 index 0000000..7fd69f2 --- /dev/null +++ b/contrib/perl5/ext/B/ramblings/reg.alloc @@ -0,0 +1,32 @@ +while ($i--) { + foo(); +} +exit + + PP code if i an int register if i an int but not a + (i.e. can't be register (i.e. can be + implicitly invalidated) implicitly invalidated) + nextstate + enterloop + + + loop: + gvsv GV (0xe6078) *i validates i validates i + postdec invalidates $i invalidates $i + and if_false goto out; + i valid; $i invalid i valid; $i invalid + + i valid; $i invalid i valid; $i invalid + nextstate + pushmark + gv GV (0xe600c) *foo + entersub validates $i; invals i + + unstack + goto loop: + + i valid; $i invalid + out: + leaveloop + nextstate + exit diff --git a/contrib/perl5/ext/B/ramblings/runtime.porting b/contrib/perl5/ext/B/ramblings/runtime.porting new file mode 100644 index 0000000..4699b25 --- /dev/null +++ b/contrib/perl5/ext/B/ramblings/runtime.porting @@ -0,0 +1,350 @@ +Notes on porting the perl runtime PP engine. +Importance: 1 = who cares?, 10 = vital +Difficulty: 1 = trivial, 10 = very difficult. Level assumes a +reasonable implementation of the SV and OP API already ported. + +OP Import Diff Comments +null 10 1 +stub 10 1 +scalar 10 1 +pushmark 10 1 PUSHMARK +wantarray 7 3 cxstack, dopoptosub +const 10 1 +gvsv 10 1 save_scalar +gv 10 1 +gelem 3 3 +padsv 10 2 SAVECLEARSV, provide_ref +padav 10 2 +padhv 10 2 +padany 1 1 +pushre 7 3 pushes an op. Blech. +rv2gv 6 5 +rv2sv 10 4 +av2arylen 7 3 sv_magic +rv2cv 8 5 sv_2cv +anoncode 7 6 cv_clone +prototype 4 4 sv_2cv +refgen 8 3 +srefgen 8 2 +ref 8 3 +bless 7 3 +backtick 5 4 +glob 5 2 do_readline +readline 8 2 do_readline +rcatline 8 2 +regcmaybe 8 1 +regcomp 8 9 pregcomp +match 8 10 +subst 8 10 +substcont 8 7 +trans 7 4 do_trans +sassign 10 3 mg_find, SvSETMAGIC +aassign 10 5 +chop 8 3 do_chop +schop 8 3 do_chop +chomp 8 3 do_chomp +schomp 8 3 do_chomp +defined 10 2 +undef 10 3 +study 4 5 +pos 8 3 PVLV, mg_find +preinc 10 2 sv_inc, SvSETMAGIC +i_preinc +predec 10 2 sv_dec, SvSETMAGIC +i_predec +postinc 10 2 sv_dec, SvSETMAGIC +i_postinc +postdec 10 2 sv_dec, SvSETMAGIC +i_postdec +pow 10 1 +multiply 10 1 +i_multiply 10 1 +divide 10 2 +i_divide 10 1 +modulo 10 2 +i_modulo 10 1 +repeat 6 4 +add 10 1 +i_add 10 1 +subtract 10 1 +i_subtract 10 1 +concat 10 2 mg_get +stringify 10 2 sv_setpvn +left_shift 10 1 +right_shift 10 1 +lt 10 1 +i_lt 10 1 +gt 10 1 +i_gt 10 1 +le 10 1 +i_le 10 1 +ge 10 1 +i_ge 10 1 +eq 10 1 +i_eq 10 1 +ne 10 1 +i_ne 10 1 +ncmp 10 1 +i_ncmp 10 1 +slt 10 2 +sgt 10 2 +sle 10 2 +sge 10 2 +seq 10 2 sv_eq +sne 10 2 +scmp 10 2 +bit_and 10 2 +bit_xor 10 2 +bit_or 10 2 +negate 10 3 +i_negate 10 1 +not 10 1 +complement 10 3 +atan2 6 1 +sin 6 1 +cos 6 1 +rand 5 2 +srand 5 2 +exp 6 1 +log 6 2 +sqrt 6 2 +int 10 2 +hex 9 2 +oct 9 2 +abs 10 1 +length 10 1 +substr 10 4 PVLV +vec 5 4 +index 9 3 +rindex 9 3 +sprintf 9 4 do_sprintf +formline 6 7 +ord 6 2 +chr 6 2 +crypt 3 2 +ucfirst 6 2 +lcfirst 6 2 +uc 6 2 +lc 6 2 +quotemeta 6 3 +rv2av 10 3 save_svref, mg_get, save_ary +aelemfast 10 2 av_fetch +aelem 10 3 +aslice 9 4 +each 10 3 hv_iternext +values 10 3 do_kv +keys 10 3 do_kv +delete 10 3 +exists 10 3 +rv2hv 10 3 save_svref, mg_get, save_ary, do_kv +helem 10 3 save_svref, provide_ref +hslice 9 4 +unpack 9 6 lengthy +pack 9 6 lengthy +split 9 9 +join 10 4 do_join +list 10 2 +lslice 9 4 +anonlist 10 2 +anonhash 10 3 +splice 9 6 +push 10 2 +pop 10 2 +shift 10 2 +unshift 10 2 +sort 6 7 +reverse 9 4 +grepstart 6 5 modifies flow of control +grepwhile 6 5 modifies flow of control +mapstart 1 1 +mapwhile 6 5 modifies flow of control +range 7 3 modifies flow of control +flip 7 4 modifies flow of control +flop 7 4 modifies flow of control +and 10 3 modifies flow of control +or 10 3 modifies flow of control +xor +cond_expr 10 3 modifies flow of control +andassign 7 3 modifies flow of control +orassign 7 3 modifies flow of control +method 8 5 +entersub 10 7 +leavesub 10 5 +caller 2 8 +warn 9 3 +die 9 3 +reset 2 2 +lineseq 1 1 +nextstate 10 1 Update stack_sp from cxstack. FREETMPS. +dbstate 3 7 +unstack +enter 10 3 cxstack, ENTER, SAVETMPS, PUSHBLOCK +leave 10 3 cxstack, SAVETMPS, LEAVE, POPBLOCK +scope 1 1 +enteriter 9 4 cxstack +iter 9 3 cxstack +enterloop 10 4 +leaveloop 10 4 +return 10 5 +last 9 6 +next 9 6 +redo 9 6 +dump 1 9 pp_goto +goto 6 9 +exit 9 2 my_exit +open 9 5 do_open +close 9 3 do_close +pipe_op 7 4 +fileno 9 2 +umask 4 2 +binmode 4 2 +tie 5 5 pp_entersub +untie 5 2 sv_unmagic +tied 5 2 +dbmopen 4 5 +dbmclose 4 2 +sselect 4 4 +select 7 3 +getc 7 2 +read 8 2 pp_sysread +enterwrite 4 4 doform +leavewrite 4 5 +prtf 4 4 do_sprintf +print 8 6 +sysopen 8 2 +sysread 8 4 +syswrite 8 4 pp_send +send 8 4 +recv 8 4 pp_sysread +eof 9 2 +tell 9 3 +seek 9 2 +truncate 8 3 +fcntl 8 4 pp_ioctl +ioctl 8 4 +flock 8 2 +socket 5 3 +sockpair 5 3 +bind 5 3 +connect 5 3 +listen 5 3 +accept 5 3 +shutdown 5 2 +gsockopt 5 3 pp_ssockopt +ssockopt 5 3 +getsockname 5 3 pp_getpeername +getpeername 5 3 +lstat 5 4 pp_stat +stat 5 4 lengthy +ftrread 5 2 cando +ftrwrite 5 2 cando +ftrexec 5 2 cando +fteread 5 2 cando +ftewrite 5 2 cando +fteexec 5 2 cando +ftis 5 2 cando +fteowned 5 2 cando +ftrowned 5 2 cando +ftzero 5 2 cando +ftsize 5 2 cando +ftmtime 5 2 cando +ftatime 5 2 cando +ftctime 5 2 cando +ftsock 5 2 cando +ftchr 5 2 cando +ftblk 5 2 cando +ftfile 5 2 cando +ftdir 5 2 cando +ftpipe 5 2 cando +ftlink 5 2 cando +ftsuid 5 2 cando +ftsgid 5 2 cando +ftsvtx 5 2 cando +fttty 5 2 cando +fttext 5 4 +ftbinary 5 4 fttext +chdir +chown +chroot +unlink +chmod +utime +rename +link +symlink +readlink +mkdir +rmdir +open_dir +readdir +telldir +seekdir +rewinddir +closedir +fork +wait +waitpid +system +exec +kill +getppid +getpgrp +setpgrp +getpriority +setpriority +time +tms +localtime +gmtime +alarm +sleep +shmget +shmctl +shmread +shmwrite +msgget +msgctl +msgsnd +msgrcv +semget +semctl +semop +require 6 9 doeval +dofile 6 9 doeval +entereval 6 9 doeval +leaveeval 6 5 +entertry 7 4 modifies flow of control +leavetry 7 3 +ghbyname +ghbyaddr +ghostent +gnbyname +gnbyaddr +gnetent +gpbyname +gpbynumber +gprotoent +gsbyname +gsbyport +gservent +shostent +snetent +sprotoent +sservent +ehostent +enetent +eprotoent +eservent +gpwnam +gpwuid +gpwent +spwent +epwent +ggrnam +ggrgid +ggrent +sgrent +egrent +getlogin +syscall + \ No newline at end of file diff --git a/contrib/perl5/ext/B/typemap b/contrib/perl5/ext/B/typemap new file mode 100644 index 0000000..7206a6a --- /dev/null +++ b/contrib/perl5/ext/B/typemap @@ -0,0 +1,69 @@ +TYPEMAP + +B::OP T_OP_OBJ +B::UNOP T_OP_OBJ +B::BINOP T_OP_OBJ +B::LOGOP T_OP_OBJ +B::CONDOP T_OP_OBJ +B::LISTOP T_OP_OBJ +B::PMOP T_OP_OBJ +B::SVOP T_OP_OBJ +B::GVOP T_OP_OBJ +B::PVOP T_OP_OBJ +B::CVOP T_OP_OBJ +B::LOOP T_OP_OBJ +B::COP T_OP_OBJ + +B::SV T_SV_OBJ +B::PV T_SV_OBJ +B::IV T_SV_OBJ +B::NV T_SV_OBJ +B::PVMG T_SV_OBJ +B::PVLV T_SV_OBJ +B::BM T_SV_OBJ +B::RV T_SV_OBJ +B::GV T_SV_OBJ +B::CV T_SV_OBJ +B::HV T_SV_OBJ +B::AV T_SV_OBJ +B::IO T_SV_OBJ + +B::MAGIC T_MG_OBJ +SSize_t T_IV +STRLEN T_IV + +INPUT +T_OP_OBJ + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = ($type) tmp; + } + else + croak(\"$var is not a reference\") + +T_SV_OBJ + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = ($type) tmp; + } + else + croak(\"$var is not a reference\") + +T_MG_OBJ + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = ($type) tmp; + } + else + croak(\"$var is not a reference\") + +OUTPUT +T_OP_OBJ + sv_setiv(newSVrv($arg, cc_opclassname((OP*)$var)), (IV)$var); + +T_SV_OBJ + make_sv_object(($arg), (SV*)($var)); + + +T_MG_OBJ + sv_setiv(newSVrv($arg, "B::MAGIC"), (IV)$var); diff --git a/contrib/perl5/ext/DB_File/Changes b/contrib/perl5/ext/DB_File/Changes new file mode 100644 index 0000000..993fe32 --- /dev/null +++ b/contrib/perl5/ext/DB_File/Changes @@ -0,0 +1,205 @@ + +0.1 + + First Release. + +0.2 + + When DB_File is opening a database file it no longer terminates the + process if dbopen returned an error. This allows file protection + errors to be caught at run time. Thanks to Judith Grass + for spotting the bug. + +0.3 + + Added prototype support for multiple btree compare callbacks. + +1.0 + + DB_File has been in use for over a year. To reflect that, the + version number has been incremented to 1.0. + + Added complete support for multiple concurrent callbacks. + + Using the push method on an empty list didn't work properly. This + has been fixed. + +1.01 + + Fixed a core dump problem with SunOS. + + The return value from TIEHASH wasn't set to NULL when dbopen + returned an error. + +1.02 + + Merged OS/2 specific code into DB_File.xs + + Removed some redundant code in DB_File.xs. + + Documentation update. + + Allow negative subscripts with RECNO interface. + + Changed the default flags from O_RDWR to O_CREAT|O_RDWR. + + The example code which showed how to lock a database needed a call + to sync added. Without it the resultant database file was empty. + + Added get_dup method. + +1.03 + + Documentation update. + + DB_File now imports the constants (O_RDWR, O_CREAT etc.) from Fcntl + automatically. + + The standard hash function exists is now supported. + + Modified the behavior of get_dup. When it returns an associative + array, the value is the count of the number of matching BTREE + values. + +1.04 + + Minor documentation changes. + + Fixed a bug in hash_cb. Patches supplied by Dave Hammen, + . + + Fixed a bug with the constructors for DB_File::HASHINFO, + DB_File::BTREEINFO and DB_File::RECNOINFO. Also tidied up the + constructors to make them -w clean. + + Reworked part of the test harness to be more locale friendly. + +1.05 + + Made all scripts in the documentation strict and -w clean. + + Added logic to DB_File.xs to allow the module to be built after + Perl is installed. + +1.06 + + Minor namespace cleanup: Localized PrintBtree. + +1.07 + + Fixed bug with RECNO, where bval wasn't defaulting to "\n". + +1.08 + + Documented operation of bval. + +1.09 + + Minor bug fix in DB_File::HASHINFO, DB_File::RECNOINFO and + DB_File::BTREEINFO. + + Changed default mode to 0666. + +1.10 + + Fixed fd method so that it still returns -1 for in-memory files + when db 1.86 is used. + +1.11 + + Documented the untie gotcha. + +1.12 + + Documented the incompatibility with version 2 of Berkeley DB. + +1.13 + + Minor changes to DB_FIle.xs and DB_File.pm + +1.14 + + Made it illegal to tie an associative array to a RECNO database and + an ordinary array to a HASH or BTREE database. + +1.15 + + Patch from Gisle Aas to suppress "use of undefined + value" warning with db_get and db_seq. + + Patch from Gisle Aas to make DB_File export only the + O_* constants from Fcntl. + + Removed the DESTROY method from the DB_File::HASHINFO module. + + Previously DB_File hard-wired the class name of any object that it + created to "DB_File". This makes sub-classing difficult. Now + DB_File creats objects in the namespace of the package it has been + inherited into. + + +1.16 + + A harmless looking tab was causing Makefile.PL to fail on AIX 3.2.5 + + Small fix for the AIX strict C compiler XLC which doesn't like + __attribute__ being defined via proto.h and redefined via db.h. Fix + courtesy of Jarkko Hietaniemi. + +1.50 + + DB_File can now build with either DB 1.x or 2.x, but not both at + the same time. + +1.51 + + Fixed the test harness so that it doesn't expect DB_File to have + been installed by the main Perl build. + + + Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent + +1.52 + + Patch from Nick Ing-Simmons now allows DB_File to build on NT. + Merged 1.15 patch. + +1.53 + + Added DB_RENUMBER to flags for recno. + +1.54 + + Fixed a small bug in the test harness when run under win32 + The emulation of fd when useing DB 2.x was busted. + +1.55 + Merged 1.16 changes. + +1.56 + Documented the Solaris 2.5 mutex bug + +1.57 + If Perl has been compiled with Threads support,the symbol op will be + defined. This clashes with a field name in db.h, so it needs to be + #undef'ed before db.h is included. + +1.58 + Tied Array support was enhanced in Perl 5.004_57. DB_File now + supports PUSH,POP,SHIFT,UNSHIFT & STORESIZE. + + Fixed a problem with the use of sv_setpvn. When the size is + specified as 0, it does a strlen on the data. This was ok for DB + 1.x, but isn't for DB 2.x. + +1.59 + Updated the license section. + + Berkeley DB 2.4.10 disallows zero length keys. Tests 32 & 42 in + db-btree.t and test 27 in db-hash.t failed because of this change. + Those tests have been zapped. + + Added dbinfo to the distribution. + +1.60 + Changed the test to check for full tied array support diff --git a/contrib/perl5/ext/DB_File/DB_File.pm b/contrib/perl5/ext/DB_File/DB_File.pm new file mode 100644 index 0000000..fcd0746 --- /dev/null +++ b/contrib/perl5/ext/DB_File/DB_File.pm @@ -0,0 +1,1695 @@ +# DB_File.pm -- Perl 5 interface to Berkeley DB +# +# written by Paul Marquess (pmarquess@bfsec.bt.co.uk) +# last modified 16th May 1998 +# version 1.60 +# +# Copyright (c) 1995-8 Paul Marquess. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + + +package DB_File::HASHINFO ; + +require 5.003 ; + +use strict; +use Carp; +require Tie::Hash; +@DB_File::HASHINFO::ISA = qw(Tie::Hash); + +sub new +{ + my $pkg = shift ; + my %x ; + tie %x, $pkg ; + bless \%x, $pkg ; +} + + +sub TIEHASH +{ + my $pkg = shift ; + + bless { VALID => { map {$_, 1} + qw( bsize ffactor nelem cachesize hash lorder) + }, + GOT => {} + }, $pkg ; +} + + +sub FETCH +{ + my $self = shift ; + my $key = shift ; + + return $self->{GOT}{$key} if exists $self->{VALID}{$key} ; + + my $pkg = ref $self ; + croak "${pkg}::FETCH - Unknown element '$key'" ; +} + + +sub STORE +{ + my $self = shift ; + my $key = shift ; + my $value = shift ; + + if ( exists $self->{VALID}{$key} ) + { + $self->{GOT}{$key} = $value ; + return ; + } + + my $pkg = ref $self ; + croak "${pkg}::STORE - Unknown element '$key'" ; +} + +sub DELETE +{ + my $self = shift ; + my $key = shift ; + + if ( exists $self->{VALID}{$key} ) + { + delete $self->{GOT}{$key} ; + return ; + } + + my $pkg = ref $self ; + croak "DB_File::HASHINFO::DELETE - Unknown element '$key'" ; +} + +sub EXISTS +{ + my $self = shift ; + my $key = shift ; + + exists $self->{VALID}{$key} ; +} + +sub NotHere +{ + my $self = shift ; + my $method = shift ; + + croak ref($self) . " does not define the method ${method}" ; +} + +sub FIRSTKEY { my $self = shift ; $self->NotHere("FIRSTKEY") } +sub NEXTKEY { my $self = shift ; $self->NotHere("NEXTKEY") } +sub CLEAR { my $self = shift ; $self->NotHere("CLEAR") } + +package DB_File::RECNOINFO ; + +use strict ; + +@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ; + +sub TIEHASH +{ + my $pkg = shift ; + + bless { VALID => { map {$_, 1} + qw( bval cachesize psize flags lorder reclen bfname ) + }, + GOT => {}, + }, $pkg ; +} + +package DB_File::BTREEINFO ; + +use strict ; + +@DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ; + +sub TIEHASH +{ + my $pkg = shift ; + + bless { VALID => { map {$_, 1} + qw( flags cachesize maxkeypage minkeypage psize + compare prefix lorder ) + }, + GOT => {}, + }, $pkg ; +} + + +package DB_File ; + +use strict; +use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO $db_version) ; +use Carp; + + +$VERSION = "1.60" ; + +#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; +$DB_BTREE = new DB_File::BTREEINFO ; +$DB_HASH = new DB_File::HASHINFO ; +$DB_RECNO = new DB_File::RECNOINFO ; + +require Tie::Hash; +require Exporter; +use AutoLoader; +require DynaLoader; +@ISA = qw(Tie::Hash Exporter DynaLoader); +@EXPORT = qw( + $DB_BTREE $DB_HASH $DB_RECNO + + BTREEMAGIC + BTREEVERSION + DB_LOCK + DB_SHMEM + DB_TXN + HASHMAGIC + HASHVERSION + MAX_PAGE_NUMBER + MAX_PAGE_OFFSET + MAX_REC_NUMBER + RET_ERROR + RET_SPECIAL + RET_SUCCESS + R_CURSOR + R_DUP + R_FIRST + R_FIXEDLEN + R_IAFTER + R_IBEFORE + R_LAST + R_NEXT + R_NOKEY + R_NOOVERWRITE + R_PREV + R_RECNOSYNC + R_SETCURSOR + R_SNAPSHOT + __R_UNUSED + +); + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + my($pack,$file,$line) = caller; + croak "Your vendor has not defined DB macro $constname, used at $file line $line. +"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + + +eval { + # Make all Fcntl O_XXX constants available for importing + require Fcntl; + my @O = grep /^O_/, @Fcntl::EXPORT; + Fcntl->import(@O); # first we import what we want to export + push(@EXPORT, @O); +}; + +## import borrowed from IO::File +## exports Fcntl constants if available. +#sub import { +# my $pkg = shift; +# my $callpkg = caller; +# Exporter::export $pkg, $callpkg, @_; +# eval { +# require Fcntl; +# Exporter::export 'Fcntl', $callpkg, '/^O_/'; +# }; +#} + +bootstrap DB_File $VERSION; + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. + +sub tie_hash_or_array +{ + my (@arg) = @_ ; + my $tieHASH = ( (caller(1))[3] =~ /TIEHASH/ ) ; + + $arg[4] = tied %{ $arg[4] } + if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ; + + # make recno in Berkeley DB version 2 work like recno in version 1. + if ($db_version > 1 and defined $arg[4] and $arg[4] =~ /RECNO/ and + $arg[1] and ! -e $arg[1]) { + open(FH, ">$arg[1]") or return undef ; + close FH ; + chmod $arg[3] ? $arg[3] : 0666 , $arg[1] ; + } + + DoTie_($tieHASH, @arg) ; +} + +sub TIEHASH +{ + tie_hash_or_array(@_) ; +} + +sub TIEARRAY +{ + tie_hash_or_array(@_) ; +} + +sub CLEAR +{ + my $self = shift; + my $key = "" ; + my $value = "" ; + my $status = $self->seq($key, $value, R_FIRST()); + my @keys; + + while ($status == 0) { + push @keys, $key; + $status = $self->seq($key, $value, R_NEXT()); + } + foreach $key (reverse @keys) { + my $s = $self->del($key); + } +} + +sub EXTEND { } + +sub STORESIZE +{ + my $self = shift; + my $length = shift ; + my $current_length = $self->length() ; + + if ($length < $current_length) { + my $key ; + for ($key = $current_length - 1 ; $key >= $length ; -- $key) + { $self->del($key) } + } + elsif ($length > $current_length) { + $self->put($length-1, "") ; + } +} + +sub get_dup +{ + croak "Usage: \$db->get_dup(key [,flag])\n" + unless @_ == 2 or @_ == 3 ; + + my $db = shift ; + my $key = shift ; + my $flag = shift ; + my $value = 0 ; + my $origkey = $key ; + my $wantarray = wantarray ; + my %values = () ; + my @values = () ; + my $counter = 0 ; + my $status = 0 ; + + # iterate through the database until either EOF ($status == 0) + # or a different key is encountered ($key ne $origkey). + for ($status = $db->seq($key, $value, R_CURSOR()) ; + $status == 0 and $key eq $origkey ; + $status = $db->seq($key, $value, R_NEXT()) ) { + + # save the value or count number of matches + if ($wantarray) { + if ($flag) + { ++ $values{$value} } + else + { push (@values, $value) } + } + else + { ++ $counter } + + } + + return ($wantarray ? ($flag ? %values : @values) : $counter) ; +} + + +1; +__END__ + +=head1 NAME + +DB_File - Perl5 access to Berkeley DB version 1.x + +=head1 SYNOPSIS + + use DB_File ; + + [$X =] tie %hash, 'DB_File', [$filename, $flags, $mode, $DB_HASH] ; + [$X =] tie %hash, 'DB_File', $filename, $flags, $mode, $DB_BTREE ; + [$X =] tie @array, 'DB_File', $filename, $flags, $mode, $DB_RECNO ; + + $status = $X->del($key [, $flags]) ; + $status = $X->put($key, $value [, $flags]) ; + $status = $X->get($key, $value [, $flags]) ; + $status = $X->seq($key, $value, $flags) ; + $status = $X->sync([$flags]) ; + $status = $X->fd ; + + # BTREE only + $count = $X->get_dup($key) ; + @list = $X->get_dup($key) ; + %list = $X->get_dup($key, 1) ; + + # RECNO only + $a = $X->length; + $a = $X->pop ; + $X->push(list); + $a = $X->shift; + $X->unshift(list); + + untie %hash ; + untie @array ; + +=head1 DESCRIPTION + +B is a module which allows Perl programs to make use of the +facilities provided by Berkeley DB version 1.x (if you have a newer +version of DB, see L). It is +assumed that you have a copy of the Berkeley DB manual pages at hand +when reading this documentation. The interface defined here mirrors the +Berkeley DB interface closely. + +Berkeley DB is a C library which provides a consistent interface to a +number of database formats. B provides an interface to all +three of the database types currently supported by Berkeley DB. + +The file types are: + +=over 5 + +=item B + +This database type allows arbitrary key/value pairs to be stored in data +files. This is equivalent to the functionality provided by other +hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though, +the files created using DB_HASH are not compatible with any of the +other packages mentioned. + +A default hashing algorithm, which will be adequate for most +applications, is built into Berkeley DB. If you do need to use your own +hashing algorithm it is possible to write your own in Perl and have +B use it instead. + +=item B + +The btree format allows arbitrary key/value pairs to be stored in a +sorted, balanced binary tree. + +As with the DB_HASH format, it is possible to provide a user defined +Perl routine to perform the comparison of keys. By default, though, the +keys are stored in lexical order. + +=item B + +DB_RECNO allows both fixed-length and variable-length flat text files +to be manipulated using the same key/value pair interface as in DB_HASH +and DB_BTREE. In this case the key will consist of a record (line) +number. + +=back + +=head2 Using DB_File with Berkeley DB version 2 + +Although B is intended to be used with Berkeley DB version 1, +it can also be used with version 2. In this case the interface is +limited to the functionality provided by Berkeley DB 1.x. Anywhere the +version 2 interface differs, B arranges for it to work like +version 1. This feature allows B scripts that were built with +version 1 to be migrated to version 2 without any changes. + +If you want to make use of the new features available in Berkeley DB +2.x, use the Perl module B instead. + +At the time of writing this document the B module is still +alpha quality (the version number is < 1.0), and so unsuitable for use +in any serious development work. Once its version number is >= 1.0, it +is considered stable enough for real work. + +B The database file format has changed in Berkeley DB version 2. +If you cannot recreate your databases, you must dump any existing +databases with the C utility that comes with Berkeley DB. +Once you have upgraded DB_File to use Berkeley DB version 2, your +databases can be recreated using C. Refer to the Berkeley DB +documentation for further details. + +Please read L before using version 2.x of Berkeley DB with +DB_File. + +=head2 Interface to Berkeley DB + +B allows access to Berkeley DB files using the tie() mechanism +in Perl 5 (for full details, see L). This facility +allows B to access Berkeley DB files using either an +associative array (for DB_HASH & DB_BTREE file types) or an ordinary +array (for the DB_RECNO file type). + +In addition to the tie() interface, it is also possible to access most +of the functions provided in the Berkeley DB API directly. +See L. + +=head2 Opening a Berkeley DB Database File + +Berkeley DB uses the function dbopen() to open or create a database. +Here is the C prototype for dbopen(): + + DB* + dbopen (const char * file, int flags, int mode, + DBTYPE type, const void * openinfo) + +The parameter C is an enumeration which specifies which of the 3 +interface methods (DB_HASH, DB_BTREE or DB_RECNO) is to be used. +Depending on which of these is actually chosen, the final parameter, +I points to a data structure which allows tailoring of the +specific interface method. + +This interface is handled slightly differently in B. Here is +an equivalent call using B: + + tie %array, 'DB_File', $filename, $flags, $mode, $DB_HASH ; + +The C, C and C parameters are the direct +equivalent of their dbopen() counterparts. The final parameter $DB_HASH +performs the function of both the C and C parameters in +dbopen(). + +In the example above $DB_HASH is actually a pre-defined reference to a +hash object. B has three of these pre-defined references. +Apart from $DB_HASH, there is also $DB_BTREE and $DB_RECNO. + +The keys allowed in each of these pre-defined references is limited to +the names used in the equivalent C structure. So, for example, the +$DB_HASH reference will only allow keys called C, C, +C, C, C and C. + +To change one of these elements, just assign to it like this: + + $DB_HASH->{'cachesize'} = 10000 ; + +The three predefined variables $DB_HASH, $DB_BTREE and $DB_RECNO are +usually adequate for most applications. If you do need to create extra +instances of these objects, constructors are available for each file +type. + +Here are examples of the constructors and the valid options available +for DB_HASH, DB_BTREE and DB_RECNO respectively. + + $a = new DB_File::HASHINFO ; + $a->{'bsize'} ; + $a->{'cachesize'} ; + $a->{'ffactor'}; + $a->{'hash'} ; + $a->{'lorder'} ; + $a->{'nelem'} ; + + $b = new DB_File::BTREEINFO ; + $b->{'flags'} ; + $b->{'cachesize'} ; + $b->{'maxkeypage'} ; + $b->{'minkeypage'} ; + $b->{'psize'} ; + $b->{'compare'} ; + $b->{'prefix'} ; + $b->{'lorder'} ; + + $c = new DB_File::RECNOINFO ; + $c->{'bval'} ; + $c->{'cachesize'} ; + $c->{'psize'} ; + $c->{'flags'} ; + $c->{'lorder'} ; + $c->{'reclen'} ; + $c->{'bfname'} ; + +The values stored in the hashes above are mostly the direct equivalent +of their C counterpart. Like their C counterparts, all are set to a +default values - that means you don't have to set I of the +values when you only want to change one. Here is an example: + + $a = new DB_File::HASHINFO ; + $a->{'cachesize'} = 12345 ; + tie %y, 'DB_File', "filename", $flags, 0777, $a ; + +A few of the options need extra discussion here. When used, the C +equivalent of the keys C, C and C store pointers +to C functions. In B these keys are used to store references +to Perl subs. Below are templates for each of the subs: + + sub hash + { + my ($data) = @_ ; + ... + # return the hash value for $data + return $hash ; + } + + sub compare + { + my ($key, $key2) = @_ ; + ... + # return 0 if $key1 eq $key2 + # -1 if $key1 lt $key2 + # 1 if $key1 gt $key2 + return (-1 , 0 or 1) ; + } + + sub prefix + { + my ($key, $key2) = @_ ; + ... + # return number of bytes of $key2 which are + # necessary to determine that it is greater than $key1 + return $bytes ; + } + +See L for an example of using the +C template. + +If you are using the DB_RECNO interface and you intend making use of +C, you should check out L. + +=head2 Default Parameters + +It is possible to omit some or all of the final 4 parameters in the +call to C and let them take default values. As DB_HASH is the most +common file format used, the call: + + tie %A, "DB_File", "filename" ; + +is equivalent to: + + tie %A, "DB_File", "filename", O_CREAT|O_RDWR, 0666, $DB_HASH ; + +It is also possible to omit the filename parameter as well, so the +call: + + tie %A, "DB_File" ; + +is equivalent to: + + tie %A, "DB_File", undef, O_CREAT|O_RDWR, 0666, $DB_HASH ; + +See L for a discussion on the use of C +in place of a filename. + +=head2 In Memory Databases + +Berkeley DB allows the creation of in-memory databases by using NULL +(that is, a C<(char *)0> in C) in place of the filename. B +uses C instead of NULL to provide this functionality. + +=head1 DB_HASH + +The DB_HASH file format is probably the most commonly used of the three +file formats that B supports. It is also very straightforward +to use. + +=head2 A Simple Example + +This example shows how to create a database, add key/value pairs to the +database, delete keys/value pairs and finally how to enumerate the +contents of the database. + + use strict ; + use DB_File ; + use vars qw( %h $k $v ) ; + + tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH + or die "Cannot open file 'fruit': $!\n"; + + # Add a few key/value pairs to the file + $h{"apple"} = "red" ; + $h{"orange"} = "orange" ; + $h{"banana"} = "yellow" ; + $h{"tomato"} = "red" ; + + # Check for existence of a key + print "Banana Exists\n\n" if $h{"banana"} ; + + # Delete a key/value pair. + delete $h{"apple"} ; + + # print the contents of the file + while (($k, $v) = each %h) + { print "$k -> $v\n" } + + untie %h ; + +here is the output: + + Banana Exists + + orange -> orange + tomato -> red + banana -> yellow + +Note that the like ordinary associative arrays, the order of the keys +retrieved is in an apparently random order. + +=head1 DB_BTREE + +The DB_BTREE format is useful when you want to store data in a given +order. By default the keys will be stored in lexical order, but as you +will see from the example shown in the next section, it is very easy to +define your own sorting function. + +=head2 Changing the BTREE sort order + +This script shows how to override the default sorting algorithm that +BTREE uses. Instead of using the normal lexical ordering, a case +insensitive compare function will be used. + + use strict ; + use DB_File ; + + my %h ; + + sub Compare + { + my ($key1, $key2) = @_ ; + "\L$key1" cmp "\L$key2" ; + } + + # specify the Perl sub that will do the comparison + $DB_BTREE->{'compare'} = \&Compare ; + + tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open file 'tree': $!\n" ; + + # Add a key/value pair to the file + $h{'Wall'} = 'Larry' ; + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + $h{'duck'} = 'donald' ; + + # Delete + delete $h{"duck"} ; + + # Cycle through the keys printing them in order. + # Note it is not necessary to sort the keys as + # the btree will have kept them in order automatically. + foreach (keys %h) + { print "$_\n" } + + untie %h ; + +Here is the output from the code above. + + mouse + Smith + Wall + +There are a few point to bear in mind if you want to change the +ordering in a BTREE database: + +=over 5 + +=item 1. + +The new compare function must be specified when you create the database. + +=item 2. + +You cannot change the ordering once the database has been created. Thus +you must use the same compare function every time you access the +database. + +=back + +=head2 Handling Duplicate Keys + +The BTREE file type optionally allows a single key to be associated +with an arbitrary number of values. This option is enabled by setting +the flags element of C<$DB_BTREE> to R_DUP when creating the database. + +There are some difficulties in using the tied hash interface if you +want to manipulate a BTREE database with duplicate keys. Consider this +code: + + use strict ; + use DB_File ; + + use vars qw($filename %h ) ; + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the associative array + # and print each key/value pair. + foreach (keys %h) + { print "$_ -> $h{$_}\n" } + + untie %h ; + +Here is the output: + + Smith -> John + Wall -> Larry + Wall -> Larry + Wall -> Larry + mouse -> mickey + +As you can see 3 records have been successfully created with key C +- the only thing is, when they are retrieved from the database they +I to have the same value, namely C. The problem is caused +by the way that the associative array interface works. Basically, when +the associative array interface is used to fetch the value associated +with a given key, it will only ever retrieve the first value. + +Although it may not be immediately obvious from the code above, the +associative array interface can be used to write values with duplicate +keys, but it cannot be used to read them back from the database. + +The way to get around this problem is to use the Berkeley DB API method +called C. This method allows sequential access to key/value +pairs. See L for details of both the C method +and the API in general. + +Here is the script above rewritten using the C API method. + + use strict ; + use DB_File ; + + use vars qw($filename $x %h $status $key $value) ; + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the btree using seq + # and print each key/value pair. + $key = $value = 0 ; + for ($status = $x->seq($key, $value, R_FIRST) ; + $status == 0 ; + $status = $x->seq($key, $value, R_NEXT) ) + { print "$key -> $value\n" } + + undef $x ; + untie %h ; + +that prints: + + Smith -> John + Wall -> Brick + Wall -> Brick + Wall -> Larry + mouse -> mickey + +This time we have got all the key/value pairs, including the multiple +values associated with the key C. + +=head2 The get_dup() Method + +B comes with a utility method, called C, to assist in +reading duplicate values from BTREE databases. The method can take the +following forms: + + $count = $x->get_dup($key) ; + @list = $x->get_dup($key) ; + %list = $x->get_dup($key, 1) ; + +In a scalar context the method returns the number of values associated +with the key, C<$key>. + +In list context, it returns all the values which match C<$key>. Note +that the values will be returned in an apparently random order. + +In list context, if the second parameter is present and evaluates +TRUE, the method returns an associative array. The keys of the +associative array correspond to the values that matched in the BTREE +and the values of the array are a count of the number of times that +particular value occurred in the BTREE. + +So assuming the database created above, we can use C like +this: + + my $cnt = $x->get_dup("Wall") ; + print "Wall occurred $cnt times\n" ; + + my %hash = $x->get_dup("Wall", 1) ; + print "Larry is there\n" if $hash{'Larry'} ; + print "There are $hash{'Brick'} Brick Walls\n" ; + + my @list = $x->get_dup("Wall") ; + print "Wall => [@list]\n" ; + + @list = $x->get_dup("Smith") ; + print "Smith => [@list]\n" ; + + @list = $x->get_dup("Dog") ; + print "Dog => [@list]\n" ; + + +and it will print: + + Wall occurred 3 times + Larry is there + There are 2 Brick Walls + Wall => [Brick Brick Larry] + Smith => [John] + Dog => [] + +=head2 Matching Partial Keys + +The BTREE interface has a feature which allows partial keys to be +matched. This functionality is I available when the C method +is used along with the R_CURSOR flag. + + $x->seq($key, $value, R_CURSOR) ; + +Here is the relevant quote from the dbopen man page where it defines +the use of the R_CURSOR flag with seq: + + Note, for the DB_BTREE access method, the returned key is not + necessarily an exact match for the specified key. The returned key + is the smallest key greater than or equal to the specified key, + permitting partial key matches and range searches. + +In the example script below, the C sub uses this feature to find +and print the first matching key/value pair given a partial key. + + use strict ; + use DB_File ; + use Fcntl ; + + use vars qw($filename $x %h $st $key $value) ; + + sub match + { + my $key = shift ; + my $value = 0; + my $orig_key = $key ; + $x->seq($key, $value, R_CURSOR) ; + print "$orig_key\t-> $key\t-> $value\n" ; + } + + $filename = "tree" ; + unlink $filename ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'mouse'} = 'mickey' ; + $h{'Wall'} = 'Larry' ; + $h{'Walls'} = 'Brick' ; + $h{'Smith'} = 'John' ; + + + $key = $value = 0 ; + print "IN ORDER\n" ; + for ($st = $x->seq($key, $value, R_FIRST) ; + $st == 0 ; + $st = $x->seq($key, $value, R_NEXT) ) + + { print "$key -> $value\n" } + + print "\nPARTIAL MATCH\n" ; + + match "Wa" ; + match "A" ; + match "a" ; + + undef $x ; + untie %h ; + +Here is the output: + + IN ORDER + Smith -> John + Wall -> Larry + Walls -> Brick + mouse -> mickey + + PARTIAL MATCH + Wa -> Wall -> Larry + A -> Smith -> John + a -> mouse -> mickey + +=head1 DB_RECNO + +DB_RECNO provides an interface to flat text files. Both variable and +fixed length records are supported. + +In order to make RECNO more compatible with Perl the array offset for +all RECNO arrays begins at 0 rather than 1 as in Berkeley DB. + +As with normal Perl arrays, a RECNO array can be accessed using +negative indexes. The index -1 refers to the last element of the array, +-2 the second last, and so on. Attempting to access an element before +the start of the array will raise a fatal run-time error. + +=head2 The 'bval' Option + +The operation of the bval option warrants some discussion. Here is the +definition of bval from the Berkeley DB 1.85 recno manual page: + + The delimiting byte to be used to mark the end of a + record for variable-length records, and the pad charac- + ter for fixed-length records. If no value is speci- + fied, newlines (``\n'') are used to mark the end of + variable-length records and fixed-length records are + padded with spaces. + +The second sentence is wrong. In actual fact bval will only default to +C<"\n"> when the openinfo parameter in dbopen is NULL. If a non-NULL +openinfo parameter is used at all, the value that happens to be in bval +will be used. That means you always have to specify bval when making +use of any of the options in the openinfo parameter. This documentation +error will be fixed in the next release of Berkeley DB. + +That clarifies the situation with regards Berkeley DB itself. What +about B? Well, the behavior defined in the quote above is +quite useful, so B conforms it. + +That means that you can specify other options (e.g. cachesize) and +still have bval default to C<"\n"> for variable length records, and +space for fixed length records. + +=head2 A Simple Example + +Here is a simple example that uses RECNO. + + use strict ; + use DB_File ; + + my @h ; + tie @h, "DB_File", "text", O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file 'text': $!\n" ; + + # Add a few key/value pairs to the file + $h[0] = "orange" ; + $h[1] = "blue" ; + $h[2] = "yellow" ; + + # Check for existence of a key + print "Element 1 Exists with value $h[1]\n" if $h[1] ; + + # use a negative index + print "The last element is $h[-1]\n" ; + print "The 2nd last element is $h[-2]\n" ; + + untie @h ; + +Here is the output from the script: + + + Element 1 Exists with value blue + The last element is yellow + The 2nd last element is blue + +=head2 Extra Methods + +If you are using a version of Perl earlier than 5.004_57, the tied +array interface is quite limited. The example script above will work, +but you won't be able to use C, C, C, C +etc. with the tied array. + +To make the interface more useful for older versions of Perl, a number +of methods are supplied with B to simulate the missing array +operations. All these methods are accessed via the object returned from +the tie call. + +Here are the methods: + +=over 5 + +=item B<$X-Epush(list) ;> + +Pushes the elements of C to the end of the array. + +=item B<$value = $X-Epop ;> + +Removes and returns the last element of the array. + +=item B<$X-Eshift> + +Removes and returns the first element of the array. + +=item B<$X-Eunshift(list) ;> + +Pushes the elements of C to the start of the array. + +=item B<$X-Elength> + +Returns the number of elements in the array. + +=back + +=head2 Another Example + +Here is a more complete example that makes use of some of the methods +described above. It also makes use of the API interface directly (see +L). + + use strict ; + use vars qw(@h $H $file $i) ; + use DB_File ; + use Fcntl ; + + $file = "text" ; + + unlink $file ; + + $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file $file: $!\n" ; + + # first create a text file to play with + $h[0] = "zero" ; + $h[1] = "one" ; + $h[2] = "two" ; + $h[3] = "three" ; + $h[4] = "four" ; + + + # Print the records in order. + # + # The length method is needed here because evaluating a tied + # array in a scalar context does not return the number of + # elements in the array. + + print "\nORIGINAL\n" ; + foreach $i (0 .. $H->length - 1) { + print "$i: $h[$i]\n" ; + } + + # use the push & pop methods + $a = $H->pop ; + $H->push("last") ; + print "\nThe last record was [$a]\n" ; + + # and the shift & unshift methods + $a = $H->shift ; + $H->unshift("first") ; + print "The first record was [$a]\n" ; + + # Use the API to add a new record after record 2. + $i = 2 ; + $H->put($i, "Newbie", R_IAFTER) ; + + # and a new record before record 1. + $i = 1 ; + $H->put($i, "New One", R_IBEFORE) ; + + # delete record 3 + $H->del(3) ; + + # now print the records in reverse order + print "\nREVERSE\n" ; + for ($i = $H->length - 1 ; $i >= 0 ; -- $i) + { print "$i: $h[$i]\n" } + + # same again, but use the API functions instead + print "\nREVERSE again\n" ; + my ($s, $k, $v) = (0, 0, 0) ; + for ($s = $H->seq($k, $v, R_LAST) ; + $s == 0 ; + $s = $H->seq($k, $v, R_PREV)) + { print "$k: $v\n" } + + undef $H ; + untie @h ; + +and this is what it outputs: + + ORIGINAL + 0: zero + 1: one + 2: two + 3: three + 4: four + + The last record was [four] + The first record was [zero] + + REVERSE + 5: last + 4: three + 3: Newbie + 2: one + 1: New One + 0: first + + REVERSE again + 5: last + 4: three + 3: Newbie + 2: one + 1: New One + 0: first + +Notes: + +=over 5 + +=item 1. + +Rather than iterating through the array, C<@h> like this: + + foreach $i (@h) + +it is necessary to use either this: + + foreach $i (0 .. $H->length - 1) + +or this: + + for ($a = $H->get($k, $v, R_FIRST) ; + $a == 0 ; + $a = $H->get($k, $v, R_NEXT) ) + +=item 2. + +Notice that both times the C method was used the record index was +specified using a variable, C<$i>, rather than the literal value +itself. This is because C will return the record number of the +inserted line via that parameter. + +=back + +=head1 THE API INTERFACE + +As well as accessing Berkeley DB using a tied hash or array, it is also +possible to make direct use of most of the API functions defined in the +Berkeley DB documentation. + +To do this you need to store a copy of the object returned from the tie. + + $db = tie %hash, "DB_File", "filename" ; + +Once you have done that, you can access the Berkeley DB API functions +as B methods directly like this: + + $db->put($key, $value, R_NOOVERWRITE) ; + +B If you have saved a copy of the object returned from +C, the underlying database file will I be closed until both +the tied variable is untied and all copies of the saved object are +destroyed. + + use DB_File ; + $db = tie %hash, "DB_File", "filename" + or die "Cannot tie filename: $!" ; + ... + undef $db ; + untie %hash ; + +See L for more details. + +All the functions defined in L are available except for +close() and dbopen() itself. The B method interface to the +supported functions have been implemented to mirror the way Berkeley DB +works whenever possible. In particular note that: + +=over 5 + +=item * + +The methods return a status value. All return 0 on success. +All return -1 to signify an error and set C<$!> to the exact +error code. The return code 1 generally (but not always) means that the +key specified did not exist in the database. + +Other return codes are defined. See below and in the Berkeley DB +documentation for details. The Berkeley DB documentation should be used +as the definitive source. + +=item * + +Whenever a Berkeley DB function returns data via one of its parameters, +the equivalent B method does exactly the same. + +=item * + +If you are careful, it is possible to mix API calls with the tied +hash/array interface in the same piece of code. Although only a few of +the methods used to implement the tied interface currently make use of +the cursor, you should always assume that the cursor has been changed +any time the tied hash/array interface is used. As an example, this +code will probably not do what you expect: + + $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE + or die "Cannot tie $filename: $!" ; + + # Get the first key/value pair and set the cursor + $X->seq($key, $value, R_FIRST) ; + + # this line will modify the cursor + $count = scalar keys %x ; + + # Get the second key/value pair. + # oops, it didn't, it got the last key/value pair! + $X->seq($key, $value, R_NEXT) ; + +The code above can be rearranged to get around the problem, like this: + + $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE + or die "Cannot tie $filename: $!" ; + + # this line will modify the cursor + $count = scalar keys %x ; + + # Get the first key/value pair and set the cursor + $X->seq($key, $value, R_FIRST) ; + + # Get the second key/value pair. + # worked this time. + $X->seq($key, $value, R_NEXT) ; + +=back + +All the constants defined in L for use in the flags parameters +in the methods defined below are also available. Refer to the Berkeley +DB documentation for the precise meaning of the flags values. + +Below is a list of the methods available. + +=over 5 + +=item B<$status = $X-Eget($key, $value [, $flags]) ;> + +Given a key (C<$key>) this method reads the value associated with it +from the database. The value read from the database is returned in the +C<$value> parameter. + +If the key does not exist the method returns 1. + +No flags are currently defined for this method. + +=item B<$status = $X-Eput($key, $value [, $flags]) ;> + +Stores the key/value pair in the database. + +If you use either the R_IAFTER or R_IBEFORE flags, the C<$key> parameter +will have the record number of the inserted key/value pair set. + +Valid flags are R_CURSOR, R_IAFTER, R_IBEFORE, R_NOOVERWRITE and +R_SETCURSOR. + +=item B<$status = $X-Edel($key [, $flags]) ;> + +Removes all key/value pairs with key C<$key> from the database. + +A return code of 1 means that the requested key was not in the +database. + +R_CURSOR is the only valid flag at present. + +=item B<$status = $X-Efd ;> + +Returns the file descriptor for the underlying database. + +See L for an example of how to make use of the +C method to lock your database. + +=item B<$status = $X-Eseq($key, $value, $flags) ;> + +This interface allows sequential retrieval from the database. See +L for full details. + +Both the C<$key> and C<$value> parameters will be set to the key/value +pair read from the database. + +The flags parameter is mandatory. The valid flag values are R_CURSOR, +R_FIRST, R_LAST, R_NEXT and R_PREV. + +=item B<$status = $X-Esync([$flags]) ;> + +Flushes any cached buffers to disk. + +R_RECNOSYNC is the only valid flag at present. + +=back + +=head1 HINTS AND TIPS + + +=head2 Locking Databases + +Concurrent access of a read-write database by several parties requires +them all to use some kind of locking. Here's an example of Tom's that +uses the I method to get the file descriptor, and then a careful +open() to give something Perl will flock() for you. Run this repeatedly +in the background to watch the locks granted in proper order. + + use DB_File; + + use strict; + + sub LOCK_SH { 1 } + sub LOCK_EX { 2 } + sub LOCK_NB { 4 } + sub LOCK_UN { 8 } + + my($oldval, $fd, $db, %db, $value, $key); + + $key = shift || 'default'; + $value = shift || 'magic'; + + $value .= " $$"; + + $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0644) + || die "dbcreat /tmp/foo.db $!"; + $fd = $db->fd; + print "$$: db fd is $fd\n"; + open(DB_FH, "+<&=$fd") || die "dup $!"; + + + unless (flock (DB_FH, LOCK_SH | LOCK_NB)) { + print "$$: CONTENTION; can't read during write update! + Waiting for read lock ($!) ...."; + unless (flock (DB_FH, LOCK_SH)) { die "flock: $!" } + } + print "$$: Read lock granted\n"; + + $oldval = $db{$key}; + print "$$: Old value was $oldval\n"; + flock(DB_FH, LOCK_UN); + + unless (flock (DB_FH, LOCK_EX | LOCK_NB)) { + print "$$: CONTENTION; must have exclusive lock! + Waiting for write lock ($!) ...."; + unless (flock (DB_FH, LOCK_EX)) { die "flock: $!" } + } + + print "$$: Write lock granted\n"; + $db{$key} = $value; + $db->sync; # to flush + sleep 10; + + flock(DB_FH, LOCK_UN); + undef $db; + untie %db; + close(DB_FH); + print "$$: Updated db to $key=$value\n"; + +=head2 Sharing Databases With C Applications + +There is no technical reason why a Berkeley DB database cannot be +shared by both a Perl and a C application. + +The vast majority of problems that are reported in this area boil down +to the fact that C strings are NULL terminated, whilst Perl strings are +not. + +Here is a real example. Netscape 2.0 keeps a record of the locations you +visit along with the time you last visited them in a DB_HASH database. +This is usually stored in the file F<~/.netscape/history.db>. The key +field in the database is the location string and the value field is the +time the location was last visited stored as a 4 byte binary value. + +If you haven't already guessed, the location string is stored with a +terminating NULL. This means you need to be careful when accessing the +database. + +Here is a snippet of code that is loosely based on Tom Christiansen's +I script (available from your nearest CPAN archive in +F). + + use strict ; + use DB_File ; + use Fcntl ; + + use vars qw( $dotdir $HISTORY %hist_db $href $binary_time $date ) ; + $dotdir = $ENV{HOME} || $ENV{LOGNAME}; + + $HISTORY = "$dotdir/.netscape/history.db"; + + tie %hist_db, 'DB_File', $HISTORY + or die "Cannot open $HISTORY: $!\n" ;; + + # Dump the complete database + while ( ($href, $binary_time) = each %hist_db ) { + + # remove the terminating NULL + $href =~ s/\x00$// ; + + # convert the binary time into a user friendly string + $date = localtime unpack("V", $binary_time); + print "$date $href\n" ; + } + + # check for the existence of a specific key + # remember to add the NULL + if ( $binary_time = $hist_db{"http://mox.perl.com/\x00"} ) { + $date = localtime unpack("V", $binary_time) ; + print "Last visited mox.perl.com on $date\n" ; + } + else { + print "Never visited mox.perl.com\n" + } + + untie %hist_db ; + +=head2 The untie() Gotcha + +If you make use of the Berkeley DB API, it is I strongly +recommended that you read L. + +Even if you don't currently make use of the API interface, it is still +worth reading it. + +Here is an example which illustrates the problem from a B +perspective: + + use DB_File ; + use Fcntl ; + + my %x ; + my $X ; + + $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_TRUNC + or die "Cannot tie first time: $!" ; + + $x{123} = 456 ; + + untie %x ; + + tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT + or die "Cannot tie second time: $!" ; + + untie %x ; + +When run, the script will produce this error message: + + Cannot tie second time: Invalid argument at bad.file line 14. + +Although the error message above refers to the second tie() statement +in the script, the source of the problem is really with the untie() +statement that precedes it. + +Having read L you will probably have already guessed that the +error is caused by the extra copy of the tied object stored in C<$X>. +If you haven't, then the problem boils down to the fact that the +B destructor, DESTROY, will not be called until I +references to the tied object are destroyed. Both the tied variable, +C<%x>, and C<$X> above hold a reference to the object. The call to +untie() will destroy the first, but C<$X> still holds a valid +reference, so the destructor will not get called and the database file +F will remain open. The fact that Berkeley DB then reports the +attempt to open a database that is alreday open via the catch-all +"Invalid argument" doesn't help. + +If you run the script with the C<-w> flag the error message becomes: + + untie attempted while 1 inner references still exist at bad.file line 12. + Cannot tie second time: Invalid argument at bad.file line 14. + +which pinpoints the real problem. Finally the script can now be +modified to fix the original problem by destroying the API object +before the untie: + + ... + $x{123} = 456 ; + + undef $X ; + untie %x ; + + $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT + ... + + +=head1 COMMON QUESTIONS + +=head2 Why is there Perl source in my database? + +If you look at the contents of a database file created by DB_File, +there can sometimes be part of a Perl script included in it. + +This happens because Berkeley DB uses dynamic memory to allocate +buffers which will subsequently be written to the database file. Being +dynamic, the memory could have been used for anything before DB +malloced it. As Berkeley DB doesn't clear the memory once it has been +allocated, the unused portions will contain random junk. In the case +where a Perl script gets written to the database, the random junk will +correspond to an area of dynamic memory that happened to be used during +the compilation of the script. + +Unless you don't like the possibility of there being part of your Perl +scripts embedded in a database file, this is nothing to worry about. + +=head2 How do I store complex data structures with DB_File? + +Although B cannot do this directly, there is a module which +can layer transparently over B to accomplish this feat. + +Check out the MLDBM module, available on CPAN in the directory +F. + +=head2 What does "Invalid Argument" mean? + +You will get this error message when one of the parameters in the +C call is wrong. Unfortunately there are quite a few parameters to +get wrong, so it can be difficult to figure out which one it is. + +Here are a couple of possibilities: + +=over 5 + +=item 1. + +Attempting to reopen a database without closing it. + +=item 2. + +Using the O_WRONLY flag. + +=back + +=head2 What does "Bareword 'DB_File' not allowed" mean? + +You will encounter this particular error message when you have the +C pragma (or the full strict pragma) in your script. +Consider this script: + + use strict ; + use DB_File ; + use vars qw(%x) ; + tie %x, DB_File, "filename" ; + +Running it produces the error in question: + + Bareword "DB_File" not allowed while "strict subs" in use + +To get around the error, place the word C in either single or +double quotes, like this: + + tie %x, "DB_File", "filename" ; + +Although it might seem like a real pain, it is really worth the effort +of having a C in all your scripts. + +=head1 HISTORY + +Moved to the Changes file. + +=head1 BUGS + +Some older versions of Berkeley DB had problems with fixed length +records using the RECNO file format. This problem has been fixed since +version 1.85 of Berkeley DB. + +I am sure there are bugs in the code. If you do find any, or can +suggest any enhancements, I would welcome your comments. + +=head1 AVAILABILITY + +B comes with the standard Perl source distribution. Look in +the directory F. Given the amount of time between releases +of Perl the version that ships with Perl is quite likely to be out of +date, so the most recent version can always be found on CPAN (see +L for details), in the directory +F. + +This version of B will work with either version 1.x or 2.x of +Berkeley DB, but is limited to the functionality provided by version 1. + +The official web site for Berkeley DB is +F. The ftp equivalent is +F. Both versions 1 and 2 of Berkeley DB are +available there. + +Alternatively, Berkeley DB version 1 is available at your nearest CPAN +archive in F. + +If you are running IRIX, then get Berkeley DB version 1 from +F. It has the patches necessary to +compile properly on IRIX 5.3. + +=head1 COPYRIGHT + +Copyright (c) 1995-8 Paul Marquess. All rights reserved. This program +is free software; you can redistribute it and/or modify it under the +same terms as Perl itself. + +Although B is covered by the Perl license, the library it +makes use of, namely Berkeley DB, is not. Berkeley DB has its own +copyright and its own license. Please take the time to read it. + +Here are are few words taken from the Berkeley DB FAQ (at +http://www.sleepycat.com) regarding the license: + + Do I have to license DB to use it in Perl scripts? + + No. The Berkeley DB license requires that software that uses + Berkeley DB be freely redistributable. In the case of Perl, that + software is Perl, and not your scripts. Any Perl scripts that you + write are your property, including scripts that make use of + Berkeley DB. Neither the Perl license nor the Berkeley DB license + place any restriction on what you may do with them. + +If you are in any doubt about the license situation, contact either the +Berkeley DB authors or the author of DB_File. See L<"AUTHOR"> for details. + + +=head1 SEE ALSO + +L, L, L, L, L + +=head1 AUTHOR + +The DB_File interface was written by Paul Marquess +Epmarquess@bfsec.bt.co.ukE. +Questions about the DB system itself may be addressed to +Edb@sleepycat.com. + +=cut diff --git a/contrib/perl5/ext/DB_File/DB_File.xs b/contrib/perl5/ext/DB_File/DB_File.xs new file mode 100644 index 0000000..c661023 --- /dev/null +++ b/contrib/perl5/ext/DB_File/DB_File.xs @@ -0,0 +1,1497 @@ +/* + + DB_File.xs -- Perl 5 interface to Berkeley DB + + written by Paul Marquess (pmarquess@bfsec.bt.co.uk) + last modified 16th May 1998 + version 1.60 + + All comments/suggestions/problems are welcome + + Copyright (c) 1995, 1996, 1997, 1998 Paul Marquess. All rights reserved. + This program is free software; you can redistribute it and/or + modify it under the same terms as Perl itself. + + Changes: + 0.1 - Initial Release + 0.2 - No longer bombs out if dbopen returns an error. + 0.3 - Added some support for multiple btree compares + 1.0 - Complete support for multiple callbacks added. + Fixed a problem with pushing a value onto an empty list. + 1.01 - Fixed a SunOS core dump problem. + The return value from TIEHASH wasn't set to NULL when + dbopen returned an error. + 1.02 - Use ALIAS to define TIEARRAY. + Removed some redundant commented code. + Merged OS2 code into the main distribution. + Allow negative subscripts with RECNO interface. + Changed the default flags to O_CREAT|O_RDWR + 1.03 - Added EXISTS + 1.04 - fixed a couple of bugs in hash_cb. Patches supplied by + Dave Hammen, hammen@gothamcity.jsc.nasa.gov + 1.05 - Added logic to allow prefix & hash types to be specified via + Makefile.PL + 1.06 - Minor namespace cleanup: Localized PrintBtree. + 1.07 - Fixed bug with RECNO, where bval wasn't defaulting to "\n". + 1.08 - No change to DB_File.xs + 1.09 - Default mode for dbopen changed to 0666 + 1.10 - Fixed fd method so that it still returns -1 for + in-memory files when db 1.86 is used. + 1.11 - No change to DB_File.xs + 1.12 - No change to DB_File.xs + 1.13 - Tidied up a few casts. + 1.14 - Made it illegal to tie an associative array to a RECNO + database and an ordinary array to a HASH or BTREE database. + 1.50 - Make work with both DB 1.x or DB 2.x + 1.51 - Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent + 1.52 - Patch from Gisle Aas to suppress "use of + undefined value" warning with db_get and db_seq. + 1.53 - Added DB_RENUMBER to flags for recno. + 1.54 - Fixed bug in the fd method + 1.55 - Fix for AIX from Jarkko Hietaniemi + 1.56 - No change to DB_File.xs + 1.57 - added the #undef op to allow building with Threads support. + 1.58 - Fixed a problem with the use of sv_setpvn. When the + size is specified as 0, it does a strlen on the data. + This was ok for DB 1.x, but isn't for DB 2.x. + 1.59 - No change to DB_File.xs + 1.60 - Some code tidy up + + + +*/ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +/* Being the Berkeley DB we prefer the (which will be + * shortly #included by the ) __attribute__ to the possibly + * already defined __attribute__, for example by GNUC or by Perl. */ + +#undef __attribute__ + +/* If Perl has been compiled with Threads support,the symbol op will + be defined here. This clashes with a field name in db.h, so get rid of it. + */ +#ifdef op +#undef op +#endif +#include + +#include + +/* #define TRACE */ + + + +#ifdef DB_VERSION_MAJOR + +/* map version 2 features & constants onto their version 1 equivalent */ + +#ifdef DB_Prefix_t +#undef DB_Prefix_t +#endif +#define DB_Prefix_t size_t + +#ifdef DB_Hash_t +#undef DB_Hash_t +#endif +#define DB_Hash_t u_int32_t + +/* DBTYPE stays the same */ +/* HASHINFO, RECNOINFO and BTREEINFO map to DB_INFO */ +typedef DB_INFO INFO ; + +/* version 2 has db_recno_t in place of recno_t */ +typedef db_recno_t recno_t; + + +#define R_CURSOR DB_SET_RANGE +#define R_FIRST DB_FIRST +#define R_IAFTER DB_AFTER +#define R_IBEFORE DB_BEFORE +#define R_LAST DB_LAST +#define R_NEXT DB_NEXT +#define R_NOOVERWRITE DB_NOOVERWRITE +#define R_PREV DB_PREV +#define R_SETCURSOR 0 +#define R_RECNOSYNC 0 +#define R_FIXEDLEN DB_FIXEDLEN +#define R_DUP DB_DUP + +#define db_HA_hash h_hash +#define db_HA_ffactor h_ffactor +#define db_HA_nelem h_nelem +#define db_HA_bsize db_pagesize +#define db_HA_cachesize db_cachesize +#define db_HA_lorder db_lorder + +#define db_BT_compare bt_compare +#define db_BT_prefix bt_prefix +#define db_BT_flags flags +#define db_BT_psize db_pagesize +#define db_BT_cachesize db_cachesize +#define db_BT_lorder db_lorder +#define db_BT_maxkeypage +#define db_BT_minkeypage + + +#define db_RE_reclen re_len +#define db_RE_flags flags +#define db_RE_bval re_pad +#define db_RE_bfname re_source +#define db_RE_psize db_pagesize +#define db_RE_cachesize db_cachesize +#define db_RE_lorder db_lorder + +#define TXN NULL, + +#define do_SEQ(db, key, value, flag) (db->cursor->c_get)(db->cursor, &key, &value, flag) + + +#define DBT_flags(x) x.flags = 0 +#define DB_flags(x, v) x |= v + +#else /* db version 1.x */ + +typedef union INFO { + HASHINFO hash ; + RECNOINFO recno ; + BTREEINFO btree ; + } INFO ; + + +#ifdef mDB_Prefix_t +#ifdef DB_Prefix_t +#undef DB_Prefix_t +#endif +#define DB_Prefix_t mDB_Prefix_t +#endif + +#ifdef mDB_Hash_t +#ifdef DB_Hash_t +#undef DB_Hash_t +#endif +#define DB_Hash_t mDB_Hash_t +#endif + +#define db_HA_hash hash.hash +#define db_HA_ffactor hash.ffactor +#define db_HA_nelem hash.nelem +#define db_HA_bsize hash.bsize +#define db_HA_cachesize hash.cachesize +#define db_HA_lorder hash.lorder + +#define db_BT_compare btree.compare +#define db_BT_prefix btree.prefix +#define db_BT_flags btree.flags +#define db_BT_psize btree.psize +#define db_BT_cachesize btree.cachesize +#define db_BT_lorder btree.lorder +#define db_BT_maxkeypage btree.maxkeypage +#define db_BT_minkeypage btree.minkeypage + +#define db_RE_reclen recno.reclen +#define db_RE_flags recno.flags +#define db_RE_bval recno.bval +#define db_RE_bfname recno.bfname +#define db_RE_psize recno.psize +#define db_RE_cachesize recno.cachesize +#define db_RE_lorder recno.lorder + +#define TXN + +#define do_SEQ(db, key, value, flag) (db->dbp->seq)(db->dbp, &key, &value, flag) +#define DBT_flags(x) +#define DB_flags(x, v) + +#endif /* db version 1 */ + + + +#define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, TXN &key, flags) +#define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, flags) +#define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) + +#define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags) +#define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) +#ifdef DB_VERSION_MAJOR +#define db_DESTROY(db) ((db->dbp)->close)(db->dbp, 0) +#define db_close(db) ((db->dbp)->close)(db->dbp, 0) +#define db_del(db, key, flags) ((flags & R_CURSOR) \ + ? ((db->cursor)->c_del)(db->cursor, 0) \ + : ((db->dbp)->del)(db->dbp, NULL, &key, flags) ) + +#else + +#define db_DESTROY(db) ((db->dbp)->close)(db->dbp) +#define db_close(db) ((db->dbp)->close)(db->dbp) +#define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) +#define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags) + +#endif + +#define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags) + +typedef struct { + DBTYPE type ; + DB * dbp ; + SV * compare ; + SV * prefix ; + SV * hash ; + int in_memory ; + INFO info ; +#ifdef DB_VERSION_MAJOR + DBC * cursor ; +#endif + } DB_File_type; + +typedef DB_File_type * DB_File ; +typedef DBT DBTKEY ; + +#define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s) + +#define OutputValue(arg, name) \ + { if (RETVAL == 0) { \ + my_sv_setpvn(arg, name.data, name.size) ; \ + } \ + } + +#define OutputKey(arg, name) \ + { if (RETVAL == 0) \ + { \ + if (db->type != DB_RECNO) { \ + my_sv_setpvn(arg, name.data, name.size); \ + } \ + else \ + sv_setiv(arg, (I32)*(I32*)name.data - 1); \ + } \ + } + + +/* Internal Global Data */ +static recno_t Value ; +static recno_t zero = 0 ; +static DB_File CurrentDB ; +static DBTKEY empty ; + +#ifdef DB_VERSION_MAJOR + +static int +db_put(db, key, value, flags) +DB_File db ; +DBTKEY key ; +DBT value ; +u_int flags ; + +{ + int status ; + + if (flags & R_CURSOR) { + status = ((db->cursor)->c_del)(db->cursor, 0); + if (status != 0) + return status ; + + flags &= ~R_CURSOR ; + } + + return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ; + +} + +#endif /* DB_VERSION_MAJOR */ + +static void +GetVersionInfo() +{ + SV * ver_sv = perl_get_sv("DB_File::db_version", TRUE) ; +#ifdef DB_VERSION_MAJOR + int Major, Minor, Patch ; + + (void)db_version(&Major, &Minor, &Patch) ; + + /* check that libdb is recent enough */ + if (Major == 2 && Minor == 0 && Patch < 5) + croak("DB_File needs Berkeley DB 2.0.5 or greater, you have %d.%d.%d\n", + Major, Minor, Patch) ; + +#if PATCHLEVEL > 3 + sv_setpvf(ver_sv, "%d.%d", Major, Minor) ; +#else + { + char buffer[40] ; + sprintf(buffer, "%d.%d", Major, Minor) ; + sv_setpv(ver_sv, buffer) ; + } +#endif + +#else + sv_setiv(ver_sv, 1) ; +#endif + +} + + +static int +btree_compare(key1, key2) +const DBT * key1 ; +const DBT * key2 ; +{ + dSP ; + void * data1, * data2 ; + int retval ; + int count ; + + data1 = key1->data ; + data2 = key2->data ; + + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (key1->size == 0) + data1 = "" ; + if (key2->size == 0) + data2 = "" ; + + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + EXTEND(SP,2) ; + PUSHs(sv_2mortal(newSVpv(data1,key1->size))); + PUSHs(sv_2mortal(newSVpv(data2,key2->size))); + PUTBACK ; + + count = perl_call_sv(CurrentDB->compare, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + return (retval) ; + +} + +static DB_Prefix_t +btree_prefix(key1, key2) +const DBT * key1 ; +const DBT * key2 ; +{ + dSP ; + void * data1, * data2 ; + int retval ; + int count ; + + data1 = key1->data ; + data2 = key2->data ; + + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (key1->size == 0) + data1 = "" ; + if (key2->size == 0) + data2 = "" ; + + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + EXTEND(SP,2) ; + PUSHs(sv_2mortal(newSVpv(data1,key1->size))); + PUSHs(sv_2mortal(newSVpv(data2,key2->size))); + PUTBACK ; + + count = perl_call_sv(CurrentDB->prefix, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + + return (retval) ; +} + +static DB_Hash_t +hash_cb(data, size) +const void * data ; +size_t size ; +{ + dSP ; + int retval ; + int count ; + + if (size == 0) + data = "" ; + + /* DGH - Next two lines added to fix corrupted stack problem */ + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + + XPUSHs(sv_2mortal(newSVpv((char*)data,size))); + PUTBACK ; + + count = perl_call_sv(CurrentDB->hash, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + + return (retval) ; +} + + +#ifdef TRACE + +static void +PrintHash(hash) +INFO * hash ; +{ + printf ("HASH Info\n") ; + printf (" hash = %s\n", + (hash->db_HA_hash != NULL ? "redefined" : "default")) ; + printf (" bsize = %d\n", hash->db_HA_bsize) ; + printf (" ffactor = %d\n", hash->db_HA_ffactor) ; + printf (" nelem = %d\n", hash->db_HA_nelem) ; + printf (" cachesize = %d\n", hash->db_HA_cachesize) ; + printf (" lorder = %d\n", hash->db_HA_lorder) ; + +} + +static void +PrintRecno(recno) +INFO * recno ; +{ + printf ("RECNO Info\n") ; + printf (" flags = %d\n", recno->db_RE_flags) ; + printf (" cachesize = %d\n", recno->db_RE_cachesize) ; + printf (" psize = %d\n", recno->db_RE_psize) ; + printf (" lorder = %d\n", recno->db_RE_lorder) ; + printf (" reclen = %ul\n", (unsigned long)recno->db_RE_reclen) ; + printf (" bval = %d 0x%x\n", recno->db_RE_bval, recno->db_RE_bval) ; + printf (" bfname = %d [%s]\n", recno->db_RE_bfname, recno->db_RE_bfname) ; +} + +static void +PrintBtree(btree) +INFO * btree ; +{ + printf ("BTREE Info\n") ; + printf (" compare = %s\n", + (btree->db_BT_compare ? "redefined" : "default")) ; + printf (" prefix = %s\n", + (btree->db_BT_prefix ? "redefined" : "default")) ; + printf (" flags = %d\n", btree->db_BT_flags) ; + printf (" cachesize = %d\n", btree->db_BT_cachesize) ; + printf (" psize = %d\n", btree->db_BT_psize) ; +#ifndef DB_VERSION_MAJOR + printf (" maxkeypage = %d\n", btree->db_BT_maxkeypage) ; + printf (" minkeypage = %d\n", btree->db_BT_minkeypage) ; +#endif + printf (" lorder = %d\n", btree->db_BT_lorder) ; +} + +#else + +#define PrintRecno(recno) +#define PrintHash(hash) +#define PrintBtree(btree) + +#endif /* TRACE */ + + +static I32 +GetArrayLength(db) +DB_File db ; +{ + DBT key ; + DBT value ; + int RETVAL ; + + DBT_flags(key) ; + DBT_flags(value) ; + RETVAL = do_SEQ(db, key, value, R_LAST) ; + if (RETVAL == 0) + RETVAL = *(I32 *)key.data ; + else /* No key means empty file */ + RETVAL = 0 ; + + return ((I32)RETVAL) ; +} + +static recno_t +GetRecnoKey(db, value) +DB_File db ; +I32 value ; +{ + if (value < 0) { + /* Get the length of the array */ + I32 length = GetArrayLength(db) ; + + /* check for attempt to write before start of array */ + if (length + value + 1 <= 0) + croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ; + + value = length + value + 1 ; + } + else + ++ value ; + + return value ; +} + +static DB_File +ParseOpenInfo(isHASH, name, flags, mode, sv) +int isHASH ; +char * name ; +int flags ; +int mode ; +SV * sv ; +{ + SV ** svp; + HV * action ; + DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; + void * openinfo = NULL ; + INFO * info = &RETVAL->info ; + +/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ + Zero(RETVAL, 1, DB_File_type) ; + + /* Default to HASH */ + RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; + RETVAL->type = DB_HASH ; + + /* DGH - Next line added to avoid SEGV on existing hash DB */ + CurrentDB = RETVAL; + + /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */ + RETVAL->in_memory = (name == NULL) ; + + if (sv) + { + if (! SvROK(sv) ) + croak ("type parameter is not a reference") ; + + svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ; + if (svp && SvOK(*svp)) + action = (HV*) SvRV(*svp) ; + else + croak("internal error") ; + + if (sv_isa(sv, "DB_File::HASHINFO")) + { + + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_HASH database") ; + + RETVAL->type = DB_HASH ; + openinfo = (void*)info ; + + svp = hv_fetch(action, "hash", 4, FALSE); + + if (svp && SvOK(*svp)) + { + info->db_HA_hash = hash_cb ; + RETVAL->hash = newSVsv(*svp) ; + } + else + info->db_HA_hash = NULL ; + + svp = hv_fetch(action, "ffactor", 7, FALSE); + info->db_HA_ffactor = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "nelem", 5, FALSE); + info->db_HA_nelem = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "bsize", 5, FALSE); + info->db_HA_bsize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info->db_HA_cachesize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "lorder", 6, FALSE); + info->db_HA_lorder = svp ? SvIV(*svp) : 0; + + PrintHash(info) ; + } + else if (sv_isa(sv, "DB_File::BTREEINFO")) + { + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_BTREE database"); + + RETVAL->type = DB_BTREE ; + openinfo = (void*)info ; + + svp = hv_fetch(action, "compare", 7, FALSE); + if (svp && SvOK(*svp)) + { + info->db_BT_compare = btree_compare ; + RETVAL->compare = newSVsv(*svp) ; + } + else + info->db_BT_compare = NULL ; + + svp = hv_fetch(action, "prefix", 6, FALSE); + if (svp && SvOK(*svp)) + { + info->db_BT_prefix = btree_prefix ; + RETVAL->prefix = newSVsv(*svp) ; + } + else + info->db_BT_prefix = NULL ; + + svp = hv_fetch(action, "flags", 5, FALSE); + info->db_BT_flags = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info->db_BT_cachesize = svp ? SvIV(*svp) : 0; + +#ifndef DB_VERSION_MAJOR + svp = hv_fetch(action, "minkeypage", 10, FALSE); + info->btree.minkeypage = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "maxkeypage", 10, FALSE); + info->btree.maxkeypage = svp ? SvIV(*svp) : 0; +#endif + + svp = hv_fetch(action, "psize", 5, FALSE); + info->db_BT_psize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "lorder", 6, FALSE); + info->db_BT_lorder = svp ? SvIV(*svp) : 0; + + PrintBtree(info) ; + + } + else if (sv_isa(sv, "DB_File::RECNOINFO")) + { + if (isHASH) + croak("DB_File can only tie an array to a DB_RECNO database"); + + RETVAL->type = DB_RECNO ; + openinfo = (void *)info ; + + info->db_RE_flags = 0 ; + + svp = hv_fetch(action, "flags", 5, FALSE); + info->db_RE_flags = (u_long) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "reclen", 6, FALSE); + info->db_RE_reclen = (size_t) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info->db_RE_cachesize = (u_int) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "psize", 5, FALSE); + info->db_RE_psize = (u_int) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "lorder", 6, FALSE); + info->db_RE_lorder = (int) (svp ? SvIV(*svp) : 0); + +#ifdef DB_VERSION_MAJOR + info->re_source = name ; + name = NULL ; +#endif + svp = hv_fetch(action, "bfname", 6, FALSE); + if (svp && SvOK(*svp)) { + char * ptr = SvPV(*svp,PL_na) ; +#ifdef DB_VERSION_MAJOR + name = (char*) PL_na ? ptr : NULL ; +#else + info->db_RE_bfname = (char*) (PL_na ? ptr : NULL) ; +#endif + } + else +#ifdef DB_VERSION_MAJOR + name = NULL ; +#else + info->db_RE_bfname = NULL ; +#endif + + svp = hv_fetch(action, "bval", 4, FALSE); +#ifdef DB_VERSION_MAJOR + if (svp && SvOK(*svp)) + { + int value ; + if (SvPOK(*svp)) + value = (int)*SvPV(*svp, PL_na) ; + else + value = SvIV(*svp) ; + + if (info->flags & DB_FIXEDLEN) { + info->re_pad = value ; + info->flags |= DB_PAD ; + } + else { + info->re_delim = value ; + info->flags |= DB_DELIMITER ; + } + + } +#else + if (svp && SvOK(*svp)) + { + if (SvPOK(*svp)) + info->db_RE_bval = (u_char)*SvPV(*svp, PL_na) ; + else + info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ; + DB_flags(info->flags, DB_DELIMITER) ; + + } + else + { + if (info->db_RE_flags & R_FIXEDLEN) + info->db_RE_bval = (u_char) ' ' ; + else + info->db_RE_bval = (u_char) '\n' ; + DB_flags(info->flags, DB_DELIMITER) ; + } +#endif + +#ifdef DB_RENUMBER + info->flags |= DB_RENUMBER ; +#endif + + PrintRecno(info) ; + } + else + croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); + } + + + /* OS2 Specific Code */ +#ifdef OS2 +#ifdef __EMX__ + flags |= O_BINARY; +#endif /* __EMX__ */ +#endif /* OS2 */ + +#ifdef DB_VERSION_MAJOR + + { + int Flags = 0 ; + int status ; + + /* Map 1.x flags to 2.x flags */ + if ((flags & O_CREAT) == O_CREAT) + Flags |= DB_CREATE ; + +#ifdef O_NONBLOCK + if ((flags & O_NONBLOCK) == O_NONBLOCK) + Flags |= DB_EXCL ; +#endif + +#if O_RDONLY == 0 + if (flags == O_RDONLY) +#else + if (flags & O_RDONLY) == O_RDONLY) +#endif + Flags |= DB_RDONLY ; + +#ifdef O_NONBLOCK + if ((flags & O_TRUNC) == O_TRUNC) + Flags |= DB_TRUNCATE ; +#endif + + status = db_open(name, RETVAL->type, Flags, mode, NULL, openinfo, &RETVAL->dbp) ; + if (status == 0) + status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ; + + if (status) + RETVAL->dbp = NULL ; + + } +#else + RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ; +#endif + + return (RETVAL) ; +} + + +static int +not_here(s) +char *s; +{ + croak("DB_File::%s not implemented on this architecture", s); + return -1; +} + +static double +constant(name, arg) +char *name; +int arg; +{ + errno = 0; + switch (*name) { + case 'A': + break; + case 'B': + if (strEQ(name, "BTREEMAGIC")) +#ifdef BTREEMAGIC + return BTREEMAGIC; +#else + goto not_there; +#endif + if (strEQ(name, "BTREEVERSION")) +#ifdef BTREEVERSION + return BTREEVERSION; +#else + goto not_there; +#endif + break; + case 'C': + break; + case 'D': + if (strEQ(name, "DB_LOCK")) +#ifdef DB_LOCK + return DB_LOCK; +#else + goto not_there; +#endif + if (strEQ(name, "DB_SHMEM")) +#ifdef DB_SHMEM + return DB_SHMEM; +#else + goto not_there; +#endif + if (strEQ(name, "DB_TXN")) +#ifdef DB_TXN + return (U32)DB_TXN; +#else + goto not_there; +#endif + break; + case 'E': + break; + case 'F': + break; + case 'G': + break; + case 'H': + if (strEQ(name, "HASHMAGIC")) +#ifdef HASHMAGIC + return HASHMAGIC; +#else + goto not_there; +#endif + if (strEQ(name, "HASHVERSION")) +#ifdef HASHVERSION + return HASHVERSION; +#else + goto not_there; +#endif + break; + case 'I': + break; + case 'J': + break; + case 'K': + break; + case 'L': + break; + case 'M': + if (strEQ(name, "MAX_PAGE_NUMBER")) +#ifdef MAX_PAGE_NUMBER + return (U32)MAX_PAGE_NUMBER; +#else + goto not_there; +#endif + if (strEQ(name, "MAX_PAGE_OFFSET")) +#ifdef MAX_PAGE_OFFSET + return MAX_PAGE_OFFSET; +#else + goto not_there; +#endif + if (strEQ(name, "MAX_REC_NUMBER")) +#ifdef MAX_REC_NUMBER + return (U32)MAX_REC_NUMBER; +#else + goto not_there; +#endif + break; + case 'N': + break; + case 'O': + break; + case 'P': + break; + case 'Q': + break; + case 'R': + if (strEQ(name, "RET_ERROR")) +#ifdef RET_ERROR + return RET_ERROR; +#else + goto not_there; +#endif + if (strEQ(name, "RET_SPECIAL")) +#ifdef RET_SPECIAL + return RET_SPECIAL; +#else + goto not_there; +#endif + if (strEQ(name, "RET_SUCCESS")) +#ifdef RET_SUCCESS + return RET_SUCCESS; +#else + goto not_there; +#endif + if (strEQ(name, "R_CURSOR")) +#ifdef R_CURSOR + return R_CURSOR; +#else + goto not_there; +#endif + if (strEQ(name, "R_DUP")) +#ifdef R_DUP + return R_DUP; +#else + goto not_there; +#endif + if (strEQ(name, "R_FIRST")) +#ifdef R_FIRST + return R_FIRST; +#else + goto not_there; +#endif + if (strEQ(name, "R_FIXEDLEN")) +#ifdef R_FIXEDLEN + return R_FIXEDLEN; +#else + goto not_there; +#endif + if (strEQ(name, "R_IAFTER")) +#ifdef R_IAFTER + return R_IAFTER; +#else + goto not_there; +#endif + if (strEQ(name, "R_IBEFORE")) +#ifdef R_IBEFORE + return R_IBEFORE; +#else + goto not_there; +#endif + if (strEQ(name, "R_LAST")) +#ifdef R_LAST + return R_LAST; +#else + goto not_there; +#endif + if (strEQ(name, "R_NEXT")) +#ifdef R_NEXT + return R_NEXT; +#else + goto not_there; +#endif + if (strEQ(name, "R_NOKEY")) +#ifdef R_NOKEY + return R_NOKEY; +#else + goto not_there; +#endif + if (strEQ(name, "R_NOOVERWRITE")) +#ifdef R_NOOVERWRITE + return R_NOOVERWRITE; +#else + goto not_there; +#endif + if (strEQ(name, "R_PREV")) +#ifdef R_PREV + return R_PREV; +#else + goto not_there; +#endif + if (strEQ(name, "R_RECNOSYNC")) +#ifdef R_RECNOSYNC + return R_RECNOSYNC; +#else + goto not_there; +#endif + if (strEQ(name, "R_SETCURSOR")) +#ifdef R_SETCURSOR + return R_SETCURSOR; +#else + goto not_there; +#endif + if (strEQ(name, "R_SNAPSHOT")) +#ifdef R_SNAPSHOT + return R_SNAPSHOT; +#else + goto not_there; +#endif + break; + case 'S': + break; + case 'T': + break; + case 'U': + break; + case 'V': + break; + case 'W': + break; + case 'X': + break; + case 'Y': + break; + case 'Z': + break; + case '_': + break; + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +MODULE = DB_File PACKAGE = DB_File PREFIX = db_ + +BOOT: + { + GetVersionInfo() ; + + empty.data = &zero ; + empty.size = sizeof(recno_t) ; + DBT_flags(empty) ; + } + +double +constant(name,arg) + char * name + int arg + + +DB_File +db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH) + int isHASH + char * dbtype + int flags + int mode + CODE: + { + char * name = (char *) NULL ; + SV * sv = (SV *) NULL ; + + if (items >= 3 && SvOK(ST(2))) + name = (char*) SvPV(ST(2), PL_na) ; + + if (items == 6) + sv = ST(5) ; + + RETVAL = ParseOpenInfo(isHASH, name, flags, mode, sv) ; + if (RETVAL->dbp == NULL) + RETVAL = NULL ; + } + OUTPUT: + RETVAL + +int +db_DESTROY(db) + DB_File db + INIT: + CurrentDB = db ; + CLEANUP: + if (db->hash) + SvREFCNT_dec(db->hash) ; + if (db->compare) + SvREFCNT_dec(db->compare) ; + if (db->prefix) + SvREFCNT_dec(db->prefix) ; + Safefree(db) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; +#endif + + +int +db_DELETE(db, key, flags=0) + DB_File db + DBTKEY key + u_int flags + INIT: + CurrentDB = db ; + + +int +db_EXISTS(db, key) + DB_File db + DBTKEY key + CODE: + { + DBT value ; + + DBT_flags(value) ; + CurrentDB = db ; + RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ; + } + OUTPUT: + RETVAL + +int +db_FETCH(db, key, flags=0) + DB_File db + DBTKEY key + u_int flags + CODE: + { + DBT value ; + + DBT_flags(value) ; + CurrentDB = db ; + /* RETVAL = ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) ; */ + RETVAL = db_get(db, key, value, flags) ; + ST(0) = sv_newmortal(); + OutputValue(ST(0), value) + } + +int +db_STORE(db, key, value, flags=0) + DB_File db + DBTKEY key + DBT value + u_int flags + INIT: + CurrentDB = db ; + + +int +db_FIRSTKEY(db) + DB_File db + CODE: + { + DBTKEY key ; + DBT value ; + DB * Db = db->dbp ; + + DBT_flags(key) ; + DBT_flags(value) ; + CurrentDB = db ; + RETVAL = do_SEQ(db, key, value, R_FIRST) ; + ST(0) = sv_newmortal(); + OutputKey(ST(0), key) ; + } + +int +db_NEXTKEY(db, key) + DB_File db + DBTKEY key + CODE: + { + DBT value ; + DB * Db = db->dbp ; + + DBT_flags(value) ; + CurrentDB = db ; + RETVAL = do_SEQ(db, key, value, R_NEXT) ; + ST(0) = sv_newmortal(); + OutputKey(ST(0), key) ; + } + +# +# These would be nice for RECNO +# + +int +unshift(db, ...) + DB_File db + ALIAS: UNSHIFT = 1 + CODE: + { + DBTKEY key ; + DBT value ; + int i ; + int One ; + DB * Db = db->dbp ; + + DBT_flags(key) ; + DBT_flags(value) ; + CurrentDB = db ; +#ifdef DB_VERSION_MAJOR + /* get the first value */ + RETVAL = do_SEQ(db, key, value, DB_FIRST) ; + RETVAL = 0 ; +#else + RETVAL = -1 ; +#endif + for (i = items-1 ; i > 0 ; --i) + { + value.data = SvPV(ST(i), PL_na) ; + value.size = PL_na ; + One = 1 ; + key.data = &One ; + key.size = sizeof(int) ; +#ifdef DB_VERSION_MAJOR + RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ; +#else + RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ; +#endif + if (RETVAL != 0) + break; + } + } + OUTPUT: + RETVAL + +I32 +pop(db) + DB_File db + ALIAS: POP = 1 + CODE: + { + DBTKEY key ; + DBT value ; + DB * Db = db->dbp ; + + DBT_flags(key) ; + DBT_flags(value) ; + CurrentDB = db ; + + /* First get the final value */ + RETVAL = do_SEQ(db, key, value, R_LAST) ; + ST(0) = sv_newmortal(); + /* Now delete it */ + if (RETVAL == 0) + { + /* the call to del will trash value, so take a copy now */ + OutputValue(ST(0), value) ; + RETVAL = db_del(db, key, R_CURSOR) ; + if (RETVAL != 0) + sv_setsv(ST(0), &PL_sv_undef); + } + } + +I32 +shift(db) + DB_File db + ALIAS: SHIFT = 1 + CODE: + { + DBT value ; + DBTKEY key ; + DB * Db = db->dbp ; + + DBT_flags(key) ; + DBT_flags(value) ; + CurrentDB = db ; + /* get the first value */ + RETVAL = do_SEQ(db, key, value, R_FIRST) ; + ST(0) = sv_newmortal(); + /* Now delete it */ + if (RETVAL == 0) + { + /* the call to del will trash value, so take a copy now */ + OutputValue(ST(0), value) ; + RETVAL = db_del(db, key, R_CURSOR) ; + if (RETVAL != 0) + sv_setsv (ST(0), &PL_sv_undef) ; + } + } + + +I32 +push(db, ...) + DB_File db + ALIAS: PUSH = 1 + CODE: + { + DBTKEY key ; + DBTKEY * keyptr = &key ; + DBT value ; + DB * Db = db->dbp ; + int i ; + + DBT_flags(key) ; + DBT_flags(value) ; + CurrentDB = db ; + /* Set the Cursor to the Last element */ + RETVAL = do_SEQ(db, key, value, R_LAST) ; + if (RETVAL >= 0) + { + if (RETVAL == 1) + keyptr = &empty ; +#ifdef DB_VERSION_MAJOR + for (i = 1 ; i < items ; ++i) + { + + ++ (* (int*)key.data) ; + value.data = SvPV(ST(i), PL_na) ; + value.size = PL_na ; + RETVAL = (Db->put)(Db, NULL, &key, &value, 0) ; + if (RETVAL != 0) + break; + } +#else + for (i = items - 1 ; i > 0 ; --i) + { + value.data = SvPV(ST(i), PL_na) ; + value.size = PL_na ; + RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ; + if (RETVAL != 0) + break; + } +#endif + } + } + OUTPUT: + RETVAL + + +I32 +length(db) + DB_File db + ALIAS: FETCHSIZE = 1 + CODE: + CurrentDB = db ; + RETVAL = GetArrayLength(db) ; + OUTPUT: + RETVAL + + +# +# Now provide an interface to the rest of the DB functionality +# + +int +db_del(db, key, flags=0) + DB_File db + DBTKEY key + u_int flags + CODE: + CurrentDB = db ; + RETVAL = db_del(db, key, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_NOTFOUND) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + + +int +db_get(db, key, value, flags=0) + DB_File db + DBTKEY key + DBT value = NO_INIT + u_int flags + CODE: + CurrentDB = db ; + DBT_flags(value) ; + RETVAL = db_get(db, key, value, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_NOTFOUND) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + value + +int +db_put(db, key, value, flags=0) + DB_File db + DBTKEY key + DBT value + u_int flags + CODE: + CurrentDB = db ; + RETVAL = db_put(db, key, value, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_KEYEXIST) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + key if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key); + +int +db_fd(db) + DB_File db + int status = 0 ; + CODE: + CurrentDB = db ; +#ifdef DB_VERSION_MAJOR + RETVAL = -1 ; + status = (db->in_memory + ? -1 + : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ; + if (status != 0) + RETVAL = -1 ; +#else + RETVAL = (db->in_memory + ? -1 + : ((db->dbp)->fd)(db->dbp) ) ; +#endif + OUTPUT: + RETVAL + +int +db_sync(db, flags=0) + DB_File db + u_int flags + CODE: + CurrentDB = db ; + RETVAL = db_sync(db, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; +#endif + OUTPUT: + RETVAL + + +int +db_seq(db, key, value, flags) + DB_File db + DBTKEY key + DBT value = NO_INIT + u_int flags + CODE: + CurrentDB = db ; + DBT_flags(value) ; + RETVAL = db_seq(db, key, value, flags); +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_NOTFOUND) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + key + value + diff --git a/contrib/perl5/ext/DB_File/DB_File_BS b/contrib/perl5/ext/DB_File/DB_File_BS new file mode 100644 index 0000000..9282c49 --- /dev/null +++ b/contrib/perl5/ext/DB_File/DB_File_BS @@ -0,0 +1,6 @@ +# NeXT needs /usr/lib/libposix.a to load along with DB_File.so +if ( $dlsrc eq "dl_next.xs" ) { + @DynaLoader::dl_resolve_using = ( '/usr/lib/libposix.a' ); +} + +1; diff --git a/contrib/perl5/ext/DB_File/Makefile.PL b/contrib/perl5/ext/DB_File/Makefile.PL new file mode 100644 index 0000000..dbe19f1 --- /dev/null +++ b/contrib/perl5/ext/DB_File/Makefile.PL @@ -0,0 +1,20 @@ +use ExtUtils::MakeMaker 5.16 ; +use Config ; + +# OS2 is a special case, so check for it now. +my $OS2 = "-DOS2" if $Config{'osname'} eq 'os2' ; + +my $LIB = "-ldb" ; +# so is win32 +$LIB = "-llibdb" if $^O eq 'MSWin32' ; + +WriteMakefile( + NAME => 'DB_File', + LIBS => ["-L/usr/local/lib $LIB"], + MAN3PODS => ' ', # Pods will be built by installman. + #INC => '-I/usr/local/include', + VERSION_FROM => 'DB_File.pm', + XSPROTOARG => '-noprototypes', + DEFINE => "$OS2", + ); + diff --git a/contrib/perl5/ext/DB_File/dbinfo b/contrib/perl5/ext/DB_File/dbinfo new file mode 100644 index 0000000..9640ba4 --- /dev/null +++ b/contrib/perl5/ext/DB_File/dbinfo @@ -0,0 +1,96 @@ +#!/usr/local/bin/perl + +# Name: dbinfo -- identify berkeley DB version used to create +# a database file +# +# Author: Paul Marquess +# Version: 1.01 +# Date 16th April 1998 +# +# Copyright (c) 1998 Paul Marquess. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +# Todo: Print more stats on a db file, e.g. no of records +# add log/txn/lock files + +use strict ; + +my %Data = + ( + 0x053162 => { + Type => "Btree", + Versions => + { + 1 => "Unknown (older than 1.71)", + 2 => "Unknown (older than 1.71)", + 3 => "1.71 -> 1.85, 1.86", + 4 => "Unknown", + 5 => "2.0.0 -> 2.3.0", + 6 => "2.3.1 or greater", + } + }, + 0x061561 => { + Type => "Hash", + Versions => + { + 1 => "Unknown (older than 1.71)", + 2 => "1.71 -> 1.85", + 3 => "1.86", + 4 => "2.0.0 -> 2.1.0", + 5 => "2.2.6 or greater", + } + }, + ) ; + +die "Usage: dbinfo file\n" unless @ARGV == 1 ; + +print "testing file $ARGV[0]...\n\n" ; +open (F, "<$ARGV[0]") or die "Cannot open file $ARGV[0]: $!\n" ; + +my $buff ; +read F, $buff, 20 ; + +my (@info) = unpack("NNNNN", $buff) ; +my (@info1) = unpack("VVVVV", $buff) ; +my ($magic, $version, $endian) ; + +if ($Data{$info[0]}) # first try DB 1.x format +{ + $magic = $info[0] ; + $version = $info[1] ; + $endian = "Unknown" ; +} +elsif ($Data{$info[3]}) # next DB 2.x big endian +{ + $magic = $info[3] ; + $version = $info[4] ; + $endian = "Big Endian" ; +} +elsif ($Data{$info1[3]}) # next DB 2.x little endian +{ + $magic = $info1[3] ; + $version = $info1[4] ; + $endian = "Little Endian" ; +} +else + { die "not a Berkeley DB database file.\n" } + +my $type = $Data{$magic} ; +my $magic = sprintf "%06X", $magic ; + +my $ver_string = "Unknown" ; +$ver_string = $type->{Versions}{$version} + if defined $type->{Versions}{$version} ; + +print <{Type} file. +File Version ID: $version +Built with Berkeley DB: $ver_string +Byte Order: $endian +Magic: $magic +EOM + +close F ; + +exit ; diff --git a/contrib/perl5/ext/DB_File/typemap b/contrib/perl5/ext/DB_File/typemap new file mode 100644 index 0000000..7af55ae --- /dev/null +++ b/contrib/perl5/ext/DB_File/typemap @@ -0,0 +1,41 @@ +# typemap for Perl 5 interface to Berkeley +# +# written by Paul Marquess (pmarquess@bfsec.bt.co.uk) +# last modified 13th May 1998 +# version 1.59 +# +#################################### DB SECTION +# +# + +u_int T_U_INT +DB_File T_PTROBJ +DBT T_dbtdatum +DBTKEY T_dbtkeydatum + +INPUT +T_dbtkeydatum + if (db->type != DB_RECNO) { + $var.data = SvPV($arg, PL_na); + $var.size = (int)PL_na; + DBT_flags($var); + } + else { + Value = GetRecnoKey(db, SvIV($arg)) ; + $var.data = & Value; + $var.size = (int)sizeof(recno_t); + DBT_flags($var); + } +T_dbtdatum + $var.data = SvPV($arg, PL_na); + $var.size = (int)PL_na; + DBT_flags($var); + +OUTPUT + +T_dbtkeydatum + OutputKey($arg, $var) +T_dbtdatum + OutputValue($arg, $var) +T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/contrib/perl5/ext/Data/Dumper/Changes b/contrib/perl5/ext/Data/Dumper/Changes new file mode 100644 index 0000000..a164958 --- /dev/null +++ b/contrib/perl5/ext/Data/Dumper/Changes @@ -0,0 +1,160 @@ +=head1 NAME + +HISTORY - public release history for Data::Dumper + +=head1 DESCRIPTION + +=over 8 + +=item 2.09 (9 July 1998) + +Implement $Data::Dumper::Bless, suggested by Mark Daku . + +=item 2.081 (15 January 1998) + +Minor release to fix Makefile.PL not accepting MakeMaker args. + +=item 2.08 (7 December 1997) + +Glob dumps don't output superflous 'undef' anymore. + +Fixes from Gisle Aas to make Dumper() work with +overloaded strings in recent perls, and his new testsuite. + +require 5.004. + +A separate flag to always quote hash keys (on by default). + +Recreating known CODE refs is now better supported. + +Changed flawed constant SCALAR bless workaround. + +=item 2.07 (7 December 1996) + +Dumpxs output is now exactly the same as Dump. It still doesn't +honor C though. + +Regression tests test for identical output and C-ability. + +Bug in *GLOB{THING} output fixed. + +Other small enhancements. + +=item 2.06 (2 December 1996) + +Bugfix that was serious enough for new release--the bug cripples +MLDBM. Problem was "Attempt to modify readonly value..." failures +that stemmed for a misguided SvPV_force() instead of a SvPV().) + +=item 2.05 (2 December 1996) + +Fixed the type mismatch that was causing Dumpxs test to fail +on 64-bit platforms. + +GLOB elements are dumped now when C is set (using the +*GLOB{THING} syntax). + +The C option can be set to a method name to call +before probing objects for dumping. Some applications: objects with +external data, can re-bless themselves into a transitional package; +Objects the maintain ephemeral state (like open files) can put +additional information in the object to facilitate persistence. + +The corresponding C option, if set, specifies +the method call that will revive the frozen object. + +The C flag has been added to do just that. + +Dumper does more aggressive cataloging of SCALARs encountered +within ARRAY/HASH structures. Thanks to Norman Gaywood + for reporting the problem. + +Objects that C the '""' operator are now handled +properly by the C method. + +Significant additions to the testsuite. + +More documentation. + +=item 2.04beta (28 August 1996) + +Made dump of glob names respect C setting. + +[@$%] are now escaped now when in double quotes. + +=item 2.03beta (26 August 1996) + +Fixed Dumpxs. It was appending trailing nulls to globnames. +(reported by Randal Schwartz ). + +Calling the C method on a dumper object now correctly +resets the internal separator (reported by Curt Tilmes +). + +New C option to suppress the 'C = >' prefix +introduced. If the option is set, they are output only when +absolutely essential. + +The C flag is supported (but not by the XSUB version +yet). + +Embedded nulls in keys are now handled properly by Dumpxs. + +Dumper.xs now use various integer types in perl.h (should +make it compile without noises on 64 bit platforms, although +I haven't been able to test this). + +All the dump methods now return a list of strings in a list +context. + + +=item 2.02beta (13 April 1996) + +Non portable sprintf usage in XS code fixed (thanks to +Ulrich Pfeifer ). + + +=item 2.01beta (10 April 1996) + +Minor bugfix (single digit numbers were always getting quoted). + + +=item 2.00beta (9 April 1996) + +C is now the exact XSUB equivalent of C. The XS version +is 4-5 times faster. + +C. + +MLDBM example removed (as its own module, it has a separate CPAN +reality now). + +Fixed bugs in handling keys with wierd characters. Perl can be +tripped up in its implicit quoting of the word before '=>'. The +fix: C, when set, always triggers quotes +around hash keys. + +Andreas Koenig pointed out that handling octals +is busted. His patch added. + +Dead code removed, other minor documentation fixes. + + +=item 1.23 (3 Dec 1995) + +MLDBM example added. + +Several folks pointed out that quoting of ticks and backslashes +in strings is missing. Added. + +Ian Phillips pointed out that numerics may lose +precision without quotes. Fixed. + + +=item 1.21 (20 Nov 1995) + +Last stable version I can remember. + +=back + +=cut diff --git a/contrib/perl5/ext/Data/Dumper/Dumper.pm b/contrib/perl5/ext/Data/Dumper/Dumper.pm new file mode 100644 index 0000000..e3c361f --- /dev/null +++ b/contrib/perl5/ext/Data/Dumper/Dumper.pm @@ -0,0 +1,963 @@ +# +# Data/Dumper.pm +# +# convert perl data structures into perl syntax suitable for both printing +# and eval +# +# Documentation at the __END__ +# + +package Data::Dumper; + +$VERSION = $VERSION = '2.09'; + +#$| = 1; + +require 5.004; +require Exporter; +require DynaLoader; +require overload; + +use Carp; + +@ISA = qw(Exporter DynaLoader); +@EXPORT = qw(Dumper); +@EXPORT_OK = qw(DumperX); + +bootstrap Data::Dumper; + +# module vars and their defaults +$Indent = 2 unless defined $Indent; +$Purity = 0 unless defined $Purity; +$Pad = "" unless defined $Pad; +$Varname = "VAR" unless defined $Varname; +$Useqq = 0 unless defined $Useqq; +$Terse = 0 unless defined $Terse; +$Freezer = "" unless defined $Freezer; +$Toaster = "" unless defined $Toaster; +$Deepcopy = 0 unless defined $Deepcopy; +$Quotekeys = 1 unless defined $Quotekeys; +$Bless = "bless" unless defined $Bless; +#$Expdepth = 0 unless defined $Expdepth; +#$Maxdepth = 0 unless defined $Maxdepth; + +# +# expects an arrayref of values to be dumped. +# can optionally pass an arrayref of names for the values. +# names must have leading $ sign stripped. begin the name with * +# to cause output of arrays and hashes rather than refs. +# +sub new { + my($c, $v, $n) = @_; + + croak "Usage: PACKAGE->new(ARRAYREF, [ARRAYREF])" + unless (defined($v) && (ref($v) eq 'ARRAY')); + $n = [] unless (defined($n) && (ref($v) eq 'ARRAY')); + + my($s) = { + level => 0, # current recursive depth + indent => $Indent, # various styles of indenting + pad => $Pad, # all lines prefixed by this string + xpad => "", # padding-per-level + apad => "", # added padding for hash keys n such + sep => "", # list separator + seen => {}, # local (nested) refs (id => [name, val]) + todump => $v, # values to dump [] + names => $n, # optional names for values [] + varname => $Varname, # prefix to use for tagging nameless ones + purity => $Purity, # degree to which output is evalable + useqq => $Useqq, # use "" for strings (backslashitis ensues) + terse => $Terse, # avoid name output (where feasible) + freezer => $Freezer, # name of Freezer method for objects + toaster => $Toaster, # name of method to revive objects + deepcopy => $Deepcopy, # dont cross-ref, except to stop recursion + quotekeys => $Quotekeys, # quote hash keys + 'bless' => $Bless, # keyword to use for "bless" +# expdepth => $Expdepth, # cutoff depth for explicit dumping +# maxdepth => $Maxdepth, # depth beyond which we give up + }; + + if ($Indent > 0) { + $s->{xpad} = " "; + $s->{sep} = "\n"; + } + return bless($s, $c); +} + +# +# add-to or query the table of already seen references +# +sub Seen { + my($s, $g) = @_; + if (defined($g) && (ref($g) eq 'HASH')) { + my($k, $v, $id); + while (($k, $v) = each %$g) { + if (defined $v and ref $v) { + ($id) = (overload::StrVal($v) =~ /\((.*)\)$/); + if ($k =~ /^[*](.*)$/) { + $k = (ref $v eq 'ARRAY') ? ( "\\\@" . $1 ) : + (ref $v eq 'HASH') ? ( "\\\%" . $1 ) : + (ref $v eq 'CODE') ? ( "\\\&" . $1 ) : + ( "\$" . $1 ) ; + } + elsif ($k !~ /^\$/) { + $k = "\$" . $k; + } + $s->{seen}{$id} = [$k, $v]; + } + else { + carp "Only refs supported, ignoring non-ref item \$$k"; + } + } + return $s; + } + else { + return map { @$_ } values %{$s->{seen}}; + } +} + +# +# set or query the values to be dumped +# +sub Values { + my($s, $v) = @_; + if (defined($v) && (ref($v) eq 'ARRAY')) { + $s->{todump} = [@$v]; # make a copy + return $s; + } + else { + return @{$s->{todump}}; + } +} + +# +# set or query the names of the values to be dumped +# +sub Names { + my($s, $n) = @_; + if (defined($n) && (ref($n) eq 'ARRAY')) { + $s->{names} = [@$n]; # make a copy + return $s; + } + else { + return @{$s->{names}}; + } +} + +sub DESTROY {} + +# +# dump the refs in the current dumper object. +# expects same args as new() if called via package name. +# +sub Dump { + my($s) = shift; + my(@out, $val, $name); + my($i) = 0; + local(@post); + + $s = $s->new(@_) unless ref $s; + + for $val (@{$s->{todump}}) { + my $out = ""; + @post = (); + $name = $s->{names}[$i++]; + if (defined $name) { + if ($name =~ /^[*](.*)$/) { + if (defined $val) { + $name = (ref $val eq 'ARRAY') ? ( "\@" . $1 ) : + (ref $val eq 'HASH') ? ( "\%" . $1 ) : + (ref $val eq 'CODE') ? ( "\*" . $1 ) : + ( "\$" . $1 ) ; + } + else { + $name = "\$" . $1; + } + } + elsif ($name !~ /^\$/) { + $name = "\$" . $name; + } + } + else { + $name = "\$" . $s->{varname} . $i; + } + + my $valstr; + { + local($s->{apad}) = $s->{apad}; + $s->{apad} .= ' ' x (length($name) + 3) if $s->{indent} >= 2; + $valstr = $s->_dump($val, $name); + } + + $valstr = "$name = " . $valstr . ';' if @post or !$s->{terse}; + $out .= $s->{pad} . $valstr . $s->{sep}; + $out .= $s->{pad} . join(';' . $s->{sep} . $s->{pad}, @post) + . ';' . $s->{sep} if @post; + + push @out, $out; + } + return wantarray ? @out : join('', @out); +} + +# +# twist, toil and turn; +# and recurse, of course. +# +sub _dump { + my($s, $val, $name) = @_; + my($sname); + my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad); + + return "undef" unless defined $val; + + $type = ref $val; + $out = ""; + + if ($type) { + + # prep it, if it looks like an object + if ($type =~ /[a-z_:]/) { + my $freezer = $s->{freezer}; + # UNIVERSAL::can should be used here, when we can require 5.004 + if ($freezer) { + eval { $val->$freezer() }; + carp "WARNING(Freezer method call failed): $@" if $@; + } + } + + ($realpack, $realtype, $id) = + (overload::StrVal($val) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/); + + # keep a tab on it so that we dont fall into recursive pit + if (exists $s->{seen}{$id}) { +# if ($s->{expdepth} < $s->{level}) { + if ($s->{purity} and $s->{level} > 0) { + $out = ($realtype eq 'HASH') ? '{}' : + ($realtype eq 'ARRAY') ? '[]' : + "''" ; + push @post, $name . " = " . $s->{seen}{$id}[0]; + } + else { + $out = $s->{seen}{$id}[0]; + if ($name =~ /^([\@\%])/) { + my $start = $1; + if ($out =~ /^\\$start/) { + $out = substr($out, 1); + } + else { + $out = $start . '{' . $out . '}'; + } + } + } + return $out; +# } + } + else { + # store our name + $s->{seen}{$id} = [ (($name =~ /^[@%]/) ? ('\\' . $name ) : + ($realtype eq 'CODE' and + $name =~ /^[*](.*)$/) ? ('\\&' . $1 ) : + $name ), + $val ]; + } + + $s->{level}++; + $ipad = $s->{xpad} x $s->{level}; + + if ($realpack) { # we have a blessed ref + $out = $s->{'bless'} . '( '; + $blesspad = $s->{apad}; + $s->{apad} .= ' ' if ($s->{indent} >= 2); + } + + if ($realtype eq 'SCALAR') { + if ($realpack) { + $out .= 'do{\\(my $o = ' . $s->_dump($$val, "") . ')}'; + } + else { + $out .= '\\' . $s->_dump($$val, ""); + } + } + elsif ($realtype eq 'GLOB') { + $out .= '\\' . $s->_dump($$val, ""); + } + elsif ($realtype eq 'ARRAY') { + my($v, $pad, $mname); + my($i) = 0; + $out .= ($name =~ /^\@/) ? '(' : '['; + $pad = $s->{sep} . $s->{pad} . $s->{apad}; + ($name =~ /^\@(.*)$/) ? ($mname = "\$" . $1) : + ($name =~ /[]}]$/) ? ($mname = $name) : ($mname = $name . '->'); + $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/; + for $v (@$val) { + $sname = $mname . '[' . $i . ']'; + $out .= $pad . $ipad . '#' . $i if $s->{indent} >= 3; + $out .= $pad . $ipad . $s->_dump($v, $sname); + $out .= "," if $i++ < $#$val; + } + $out .= $pad . ($s->{xpad} x ($s->{level} - 1)) if $i; + $out .= ($name =~ /^\@/) ? ')' : ']'; + } + elsif ($realtype eq 'HASH') { + my($k, $v, $pad, $lpad, $mname); + $out .= ($name =~ /^\%/) ? '(' : '{'; + $pad = $s->{sep} . $s->{pad} . $s->{apad}; + $lpad = $s->{apad}; + ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) : + ($name =~ /[]}]$/) ? ($mname = $name) : ($mname = $name . '->'); + $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/; + while (($k, $v) = each %$val) { + my $nk = $s->_dump($k, ""); + $nk = $1 if !$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/; + $sname = $mname . '{' . $nk . '}'; + $out .= $pad . $ipad . $nk . " => "; + + # temporarily alter apad + $s->{apad} .= (" " x (length($nk) + 4)) if $s->{indent} >= 2; + $out .= $s->_dump($val->{$k}, $sname) . ","; + $s->{apad} = $lpad if $s->{indent} >= 2; + } + if (substr($out, -1) eq ',') { + chop $out; + $out .= $pad . ($s->{xpad} x ($s->{level} - 1)); + } + $out .= ($name =~ /^\%/) ? ')' : '}'; + } + elsif ($realtype eq 'CODE') { + $out .= '"DUMMY"'; + $out = 'sub { ' . $out . ' }'; + carp "Encountered CODE ref, using dummy placeholder" if $s->{purity}; + } + else { + croak "Can\'t handle $realtype type."; + } + + if ($realpack) { # we have a blessed ref + $out .= ', \'' . $realpack . '\'' . ' )'; + $out .= '->' . $s->{toaster} . '()' if $s->{toaster} ne ''; + $s->{apad} = $blesspad; + } + $s->{level}--; + + } + else { # simple scalar + + my $ref = \$_[1]; + # first, catalog the scalar + if ($name ne '') { + ($id) = ("$ref" =~ /\(([^\(]*)\)$/); + if (exists $s->{seen}{$id}) { + $out = $s->{seen}{$id}[0]; + return $out; + } + else { + $s->{seen}{$id} = ["\\$name", $val]; + } + } + if (ref($ref) eq 'GLOB' or "$ref" =~ /=GLOB\([^()]+\)$/) { # glob + my $name = substr($val, 1); + if ($name =~ /^[A-Za-z_][\w:]*$/) { + $name =~ s/^main::/::/; + $sname = $name; + } + else { + $sname = $s->_dump($name, ""); + $sname = '{' . $sname . '}'; + } + if ($s->{purity}) { + my $k; + local ($s->{level}) = 0; + for $k (qw(SCALAR ARRAY HASH)) { + # _dump can push into @post, so we hold our place using $postlen + my $postlen = scalar @post; + $post[$postlen] = "\*$sname = "; + local ($s->{apad}) = " " x length($post[$postlen]) if $s->{indent} >= 2; + $post[$postlen] .= $s->_dump(*{$name}{$k}, "\*$sname\{$k\}"); + } + } + $out .= '*' . $sname; + } + elsif ($val =~ /^-?[1-9]\d{0,8}$/) { # safe decimal number + $out .= $val; + } + else { # string + if ($s->{useqq}) { + $out .= qquote($val); + } + else { + $val =~ s/([\\\'])/\\$1/g; + $out .= '\'' . $val . '\''; + } + } + } + + # if we made it this far, $id was added to seen list at current + # level, so remove it to get deep copies + delete($s->{seen}{$id}) if $id and $s->{deepcopy}; + return $out; +} + +# +# non-OO style of earlier version +# +sub Dumper { + return Data::Dumper->Dump([@_]); +} + +# +# same, only calls the XS version +# +sub DumperX { + return Data::Dumper->Dumpxs([@_], []); +} + +sub Dumpf { return Data::Dumper->Dump(@_) } + +sub Dumpp { print Data::Dumper->Dump(@_) } + +# +# reset the "seen" cache +# +sub Reset { + my($s) = shift; + $s->{seen} = {}; + return $s; +} + +sub Indent { + my($s, $v) = @_; + if (defined($v)) { + if ($v == 0) { + $s->{xpad} = ""; + $s->{sep} = ""; + } + else { + $s->{xpad} = " "; + $s->{sep} = "\n"; + } + $s->{indent} = $v; + return $s; + } + else { + return $s->{indent}; + } +} + +sub Pad { + my($s, $v) = @_; + defined($v) ? (($s->{pad} = $v), return $s) : $s->{pad}; +} + +sub Varname { + my($s, $v) = @_; + defined($v) ? (($s->{varname} = $v), return $s) : $s->{varname}; +} + +sub Purity { + my($s, $v) = @_; + defined($v) ? (($s->{purity} = $v), return $s) : $s->{purity}; +} + +sub Useqq { + my($s, $v) = @_; + defined($v) ? (($s->{useqq} = $v), return $s) : $s->{useqq}; +} + +sub Terse { + my($s, $v) = @_; + defined($v) ? (($s->{terse} = $v), return $s) : $s->{terse}; +} + +sub Freezer { + my($s, $v) = @_; + defined($v) ? (($s->{freezer} = $v), return $s) : $s->{freezer}; +} + +sub Toaster { + my($s, $v) = @_; + defined($v) ? (($s->{toaster} = $v), return $s) : $s->{toaster}; +} + +sub Deepcopy { + my($s, $v) = @_; + defined($v) ? (($s->{deepcopy} = $v), return $s) : $s->{deepcopy}; +} + +sub Quotekeys { + my($s, $v) = @_; + defined($v) ? (($s->{quotekeys} = $v), return $s) : $s->{quotekeys}; +} + +sub Bless { + my($s, $v) = @_; + defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'}; +} + +# put a string value in double quotes +sub qquote { + local($_) = shift; + s/([\\\"\@\$\%])/\\$1/g; + s/\a/\\a/g; + s/[\b]/\\b/g; + s/\t/\\t/g; + s/\n/\\n/g; + s/\f/\\f/g; + s/\r/\\r/g; + s/\e/\\e/g; + +# this won't work! +# s/([^\a\b\t\n\f\r\e\038-\176])/'\\'.sprintf('%03o',ord($1))/eg; + s/([\000-\006\013\016-\032\034-\037\177\200-\377])/'\\'.sprintf('%03o',ord($1))/eg; + return "\"$_\""; +} + +1; +__END__ + +=head1 NAME + +Data::Dumper - stringified perl data structures, suitable for both printing and C + + +=head1 SYNOPSIS + + use Data::Dumper; + + # simple procedural interface + print Dumper($foo, $bar); + + # extended usage with names + print Data::Dumper->Dump([$foo, $bar], [qw(foo *ary)]); + + # configuration variables + { + local $Data::Dump::Purity = 1; + eval Data::Dumper->Dump([$foo, $bar], [qw(foo *ary)]); + } + + # OO usage + $d = Data::Dumper->new([$foo, $bar], [qw(foo *ary)]); + ... + print $d->Dump; + ... + $d->Purity(1)->Terse(1)->Deepcopy(1); + eval $d->Dump; + + +=head1 DESCRIPTION + +Given a list of scalars or reference variables, writes out their contents in +perl syntax. The references can also be objects. The contents of each +variable is output in a single Perl statement. Handles self-referential +structures correctly. + +The return value can be Ced to get back an identical copy of the +original reference structure. + +Any references that are the same as one of those passed in will be named +C<$VAR>I (where I is a numeric suffix), and other duplicate references +to substructures within C<$VAR>I will be appropriately labeled using arrow +notation. You can specify names for individual values to be dumped if you +use the C method, or you can change the default C<$VAR> prefix to +something else. See C<$Data::Dumper::Varname> and C<$Data::Dumper::Terse> +below. + +The default output of self-referential structures can be Ced, but the +nested references to C<$VAR>I will be undefined, since a recursive +structure cannot be constructed using one Perl statement. You should set the +C flag to 1 to get additional statements that will correctly fill in +these references. + +In the extended usage form, the references to be dumped can be given +user-specified names. If a name begins with a C<*>, the output will +describe the dereferenced type of the supplied reference for hashes and +arrays, and coderefs. Output of names will be avoided where possible if +the C flag is set. + +In many cases, methods that are used to set the internal state of the +object will return the object itself, so method calls can be conveniently +chained together. + +Several styles of output are possible, all controlled by setting +the C flag. See L below +for details. + + +=head2 Methods + +=over 4 + +=item I->new(I, I) + +Returns a newly created C object. The first argument is an +anonymous array of values to be dumped. The optional second argument is an +anonymous array of names for the values. The names need not have a leading +C<$> sign, and must be comprised of alphanumeric characters. You can begin +a name with a C<*> to specify that the dereferenced type must be dumped +instead of the reference itself, for ARRAY and HASH references. + +The prefix specified by C<$Data::Dumper::Varname> will be used with a +numeric suffix if the name for a value is undefined. + +Data::Dumper will catalog all references encountered while dumping the +values. Cross-references (in the form of names of substructures in perl +syntax) will be inserted at all possible points, preserving any structural +interdependencies in the original set of values. Structure traversal is +depth-first, and proceeds in order from the first supplied value to +the last. + +=item I<$OBJ>->Dump I I->Dump(I, I) + +Returns the stringified form of the values stored in the object (preserving +the order in which they were supplied to C), subject to the +configuration options below. In an array context, it returns a list +of strings corresponding to the supplied values. + +The second form, for convenience, simply calls the C method on its +arguments before dumping the object immediately. + +=item I<$OBJ>->Dumpxs I I->Dumpxs(I, I) + +This method is available if you were able to compile and install the XSUB +extension to C. It is exactly identical to the C method +above, only about 4 to 5 times faster, since it is written entirely in C. + +=item I<$OBJ>->Seen(I<[HASHREF]>) + +Queries or adds to the internal table of already encountered references. +You must use C to explicitly clear the table if needed. Such +references are not dumped; instead, their names are inserted wherever they +are encountered subsequently. This is useful especially for properly +dumping subroutine references. + +Expects a anonymous hash of name => value pairs. Same rules apply for names +as in C. If no argument is supplied, will return the "seen" list of +name => value pairs, in an array context. Otherwise, returns the object +itself. + +=item I<$OBJ>->Values(I<[ARRAYREF]>) + +Queries or replaces the internal array of values that will be dumped. +When called without arguments, returns the values. Otherwise, returns the +object itself. + +=item I<$OBJ>->Names(I<[ARRAYREF]>) + +Queries or replaces the internal array of user supplied names for the values +that will be dumped. When called without arguments, returns the names. +Otherwise, returns the object itself. + +=item I<$OBJ>->Reset + +Clears the internal table of "seen" references and returns the object +itself. + +=back + +=head2 Functions + +=over 4 + +=item Dumper(I) + +Returns the stringified form of the values in the list, subject to the +configuration options below. The values will be named C<$VAR>I in the +output, where I is a numeric suffix. Will return a list of strings +in an array context. + +=item DumperX(I) + +Identical to the C function above, but this calls the XSUB +implementation. Only available if you were able to compile and install +the XSUB extensions in C. + +=back + +=head2 Configuration Variables or Methods + +Several configuration variables can be used to control the kind of output +generated when using the procedural interface. These variables are usually +Cized in a block so that other parts of the code are not affected by +the change. + +These variables determine the default state of the object created by calling +the C method, but cannot be used to alter the state of the object +thereafter. The equivalent method names should be used instead to query +or set the internal state of the object. + +The method forms return the object itself when called with arguments, +so that they can be chained together nicely. + +=over 4 + +=item $Data::Dumper::Indent I I<$OBJ>->Indent(I<[NEWVAL]>) + +Controls the style of indentation. It can be set to 0, 1, 2 or 3. Style 0 +spews output without any newlines, indentation, or spaces between list +items. It is the most compact format possible that can still be called +valid perl. Style 1 outputs a readable form with newlines but no fancy +indentation (each level in the structure is simply indented by a fixed +amount of whitespace). Style 2 (the default) outputs a very readable form +which takes into account the length of hash keys (so the hash value lines +up). Style 3 is like style 2, but also annotates the elements of arrays +with their index (but the comment is on its own line, so array output +consumes twice the number of lines). Style 2 is the default. + +=item $Data::Dumper::Purity I I<$OBJ>->Purity(I<[NEWVAL]>) + +Controls the degree to which the output can be Ced to recreate the +supplied reference structures. Setting it to 1 will output additional perl +statements that will correctly recreate nested references. The default is +0. + +=item $Data::Dumper::Pad I I<$OBJ>->Pad(I<[NEWVAL]>) + +Specifies the string that will be prefixed to every line of the output. +Empty string by default. + +=item $Data::Dumper::Varname I I<$OBJ>->Varname(I<[NEWVAL]>) + +Contains the prefix to use for tagging variable names in the output. The +default is "VAR". + +=item $Data::Dumper::Useqq I I<$OBJ>->Useqq(I<[NEWVAL]>) + +When set, enables the use of double quotes for representing string values. +Whitespace other than space will be represented as C<[\n\t\r]>, "unsafe" +characters will be backslashed, and unprintable characters will be output as +quoted octal integers. Since setting this variable imposes a performance +penalty, the default is 0. The C method does not honor this +flag yet. + +=item $Data::Dumper::Terse I I<$OBJ>->Terse(I<[NEWVAL]>) + +When set, Data::Dumper will emit single, non-self-referential values as +atoms/terms rather than statements. This means that the C<$VAR>I names +will be avoided where possible, but be advised that such output may not +always be parseable by C. + +=item $Data::Dumper::Freezer I $I->Freezer(I<[NEWVAL]>) + +Can be set to a method name, or to an empty string to disable the feature. +Data::Dumper will invoke that method via the object before attempting to +stringify it. This method can alter the contents of the object (if, for +instance, it contains data allocated from C), and even rebless it in a +different package. The client is responsible for making sure the specified +method can be called via the object, and that the object ends up containing +only perl data types after the method has been called. Defaults to an empty +string. + +=item $Data::Dumper::Toaster I $I->Toaster(I<[NEWVAL]>) + +Can be set to a method name, or to an empty string to disable the feature. +Data::Dumper will emit a method call for any objects that are to be dumped +using the syntax CMETHOD()>. Note that this means that +the method specified will have to perform any modifications required on the +object (like creating new state within it, and/or reblessing it in a +different package) and then return it. The client is responsible for making +sure the method can be called via the object, and that it returns a valid +object. Defaults to an empty string. + +=item $Data::Dumper::Deepcopy I $I->Deepcopy(I<[NEWVAL]>) + +Can be set to a boolean value to enable deep copies of structures. +Cross-referencing will then only be done when absolutely essential +(i.e., to break reference cycles). Default is 0. + +=item $Data::Dumper::Quotekeys I $I->Quotekeys(I<[NEWVAL]>) + +Can be set to a boolean value to control whether hash keys are quoted. +A false value will avoid quoting hash keys when it looks like a simple +string. Default is 1, which will always enclose hash keys in quotes. + +=item $Data::Dumper::Bless I $I->Bless(I<[NEWVAL]>) + +Can be set to a string that specifies an alternative to the C +builtin operator used to create objects. A function with the specified +name should exist, and should accept the same arguments as the builtin. +Default is C. + +=back + +=head2 Exports + +=over 4 + +=item Dumper + +=back + +=head1 EXAMPLES + +Run these code snippets to get a quick feel for the behavior of this +module. When you are through with these examples, you may want to +add or change the various configuration variables described above, +to see their behavior. (See the testsuite in the Data::Dumper +distribution for more examples.) + + + use Data::Dumper; + + package Foo; + sub new {bless {'a' => 1, 'b' => sub { return "foo" }}, $_[0]}; + + package Fuz; # a weird REF-REF-SCALAR object + sub new {bless \($_ = \ 'fu\'z'), $_[0]}; + + package main; + $foo = Foo->new; + $fuz = Fuz->new; + $boo = [ 1, [], "abcd", \*foo, + {1 => 'a', 023 => 'b', 0x45 => 'c'}, + \\"p\q\'r", $foo, $fuz]; + + ######## + # simple usage + ######## + + $bar = eval(Dumper($boo)); + print($@) if $@; + print Dumper($boo), Dumper($bar); # pretty print (no array indices) + + $Data::Dumper::Terse = 1; # don't output names where feasible + $Data::Dumper::Indent = 0; # turn off all pretty print + print Dumper($boo), "\n"; + + $Data::Dumper::Indent = 1; # mild pretty print + print Dumper($boo); + + $Data::Dumper::Indent = 3; # pretty print with array indices + print Dumper($boo); + + $Data::Dumper::Useqq = 1; # print strings in double quotes + print Dumper($boo); + + + ######## + # recursive structures + ######## + + @c = ('c'); + $c = \@c; + $b = {}; + $a = [1, $b, $c]; + $b->{a} = $a; + $b->{b} = $a->[1]; + $b->{c} = $a->[2]; + print Data::Dumper->Dump([$a,$b,$c], [qw(a b c)]); + + + $Data::Dumper::Purity = 1; # fill in the holes for eval + print Data::Dumper->Dump([$a, $b], [qw(*a b)]); # print as @a + print Data::Dumper->Dump([$b, $a], [qw(*b a)]); # print as %b + + + $Data::Dumper::Deepcopy = 1; # avoid cross-refs + print Data::Dumper->Dump([$b, $a], [qw(*b a)]); + + + $Data::Dumper::Purity = 0; # avoid cross-refs + print Data::Dumper->Dump([$b, $a], [qw(*b a)]); + + + ######## + # object-oriented usage + ######## + + $d = Data::Dumper->new([$a,$b], [qw(a b)]); + $d->Seen({'*c' => $c}); # stash a ref without printing it + $d->Indent(3); + print $d->Dump; + $d->Reset->Purity(0); # empty the seen cache + print join "----\n", $d->Dump; + + + ######## + # persistence + ######## + + package Foo; + sub new { bless { state => 'awake' }, shift } + sub Freeze { + my $s = shift; + print STDERR "preparing to sleep\n"; + $s->{state} = 'asleep'; + return bless $s, 'Foo::ZZZ'; + } + + package Foo::ZZZ; + sub Thaw { + my $s = shift; + print STDERR "waking up\n"; + $s->{state} = 'awake'; + return bless $s, 'Foo'; + } + + package Foo; + use Data::Dumper; + $a = Foo->new; + $b = Data::Dumper->new([$a], ['c']); + $b->Freezer('Freeze'); + $b->Toaster('Thaw'); + $c = $b->Dump; + print $c; + $d = eval $c; + print Data::Dumper->Dump([$d], ['d']); + + + ######## + # symbol substitution (useful for recreating CODE refs) + ######## + + sub foo { print "foo speaking\n" } + *other = \&foo; + $bar = [ \&other ]; + $d = Data::Dumper->new([\&other,$bar],['*other','bar']); + $d->Seen({ '*foo' => \&foo }); + print $d->Dump; + + +=head1 BUGS + +Due to limitations of Perl subroutine call semantics, you cannot pass an +array or hash. Prepend it with a C<\> to pass its reference instead. This +will be remedied in time, with the arrival of prototypes in later versions +of Perl. For now, you need to use the extended usage form, and prepend the +name with a C<*> to output it as a hash or array. + +C cheats with CODE references. If a code reference is +encountered in the structure being processed, an anonymous subroutine that +contains the string '"DUMMY"' will be inserted in its place, and a warning +will be printed if C is set. You can C the result, but bear +in mind that the anonymous sub that gets created is just a placeholder. +Someday, perl will have a switch to cache-on-demand the string +representation of a compiled piece of code, I hope. If you have prior +knowledge of all the code refs that your data structures are likely +to have, you can use the C method to pre-seed the internal reference +table and make the dumped output point to them, instead. See L +above. + +The C flag is not honored by C (it always outputs +strings in single quotes). + +SCALAR objects have the weirdest looking C workaround. + + +=head1 AUTHOR + +Gurusamy Sarathy gsar@umich.edu + +Copyright (c) 1996-98 Gurusamy Sarathy. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + +=head1 VERSION + +Version 2.09 (9 July 1998) + +=head1 SEE ALSO + +perl(1) + +=cut diff --git a/contrib/perl5/ext/Data/Dumper/Dumper.xs b/contrib/perl5/ext/Data/Dumper/Dumper.xs new file mode 100644 index 0000000..d8012ee --- /dev/null +++ b/contrib/perl5/ext/Data/Dumper/Dumper.xs @@ -0,0 +1,800 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +static SV *freezer; +static SV *toaster; + +static I32 num_q _((char *s, STRLEN slen)); +static I32 esc_q _((char *dest, char *src, STRLEN slen)); +static SV *sv_x _((SV *sv, char *str, STRLEN len, I32 n)); +static I32 DD_dump _((SV *val, char *name, STRLEN namelen, SV *retval, + HV *seenhv, AV *postav, I32 *levelp, I32 indent, + SV *pad, SV *xpad, SV *apad, SV *sep, + SV *freezer, SV *toaster, + I32 purity, I32 deepcopy, I32 quotekeys, SV *bless)); + +/* does a string need to be protected? */ +static I32 +needs_quote(register char *s) +{ +TOP: + if (s[0] == ':') { + if (*++s) { + if (*s++ != ':') + return 1; + } + else + return 1; + } + if (isIDFIRST(*s)) { + while (*++s) + if (!isALNUM(*s)) + if (*s == ':') + goto TOP; + else + return 1; + } + else + return 1; + return 0; +} + +/* count the number of "'"s and "\"s in string */ +static I32 +num_q(register char *s, register STRLEN slen) +{ + register I32 ret = 0; + + while (slen > 0) { + if (*s == '\'' || *s == '\\') + ++ret; + ++s; + --slen; + } + return ret; +} + + +/* returns number of chars added to escape "'"s and "\"s in s */ +/* slen number of characters in s will be escaped */ +/* destination must be long enough for additional chars */ +static I32 +esc_q(register char *d, register char *s, register STRLEN slen) +{ + register I32 ret = 0; + + while (slen > 0) { + switch (*s) { + case '\'': + case '\\': + *d = '\\'; + ++d; ++ret; + default: + *d = *s; + ++d; ++s; --slen; + break; + } + } + return ret; +} + +/* append a repeated string to an SV */ +static SV * +sv_x(SV *sv, register char *str, STRLEN len, I32 n) +{ + if (sv == Nullsv) + sv = newSVpv("", 0); + else + assert(SvTYPE(sv) >= SVt_PV); + + if (n > 0) { + SvGROW(sv, len*n + SvCUR(sv) + 1); + if (len == 1) { + char *start = SvPVX(sv) + SvCUR(sv); + SvCUR(sv) += n; + start[n] = '\0'; + while (n > 0) + start[--n] = str[0]; + } + else + while (n > 0) { + sv_catpvn(sv, str, len); + --n; + } + } + return sv; +} + +/* + * This ought to be split into smaller functions. (it is one long function since + * it exactly parallels the perl version, which was one long thing for + * efficiency raisins.) Ugggh! + */ +static I32 +DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, + AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad, + SV *apad, SV *sep, SV *freezer, SV *toaster, I32 purity, + I32 deepcopy, I32 quotekeys, SV *bless) +{ + char tmpbuf[128]; + U32 i; + char *c, *r, *realpack, id[128]; + SV **svp; + SV *sv; + SV *blesspad = Nullsv; + SV *ipad; + SV *ival; + AV *seenentry; + char *iname; + STRLEN inamelen, idlen = 0; + U32 flags; + U32 realtype; + + if (!val) + return 0; + + flags = SvFLAGS(val); + realtype = SvTYPE(val); + + if (SvGMAGICAL(val)) + mg_get(val); + if (val == &PL_sv_undef || !SvOK(val)) { + sv_catpvn(retval, "undef", 5); + return 1; + } + if (SvROK(val)) { + + if (SvOBJECT(SvRV(val)) && freezer && + SvPOK(freezer) && SvCUR(freezer)) + { + dSP; ENTER; SAVETMPS; PUSHMARK(sp); + XPUSHs(val); PUTBACK; + i = perl_call_method(SvPVX(freezer), G_EVAL|G_SCALAR); + SPAGAIN; + if (SvTRUE(GvSV(PL_errgv))) + warn("WARNING(Freezer method call failed): %s", + SvPVX(GvSV(PL_errgv))); + else if (i) + val = newSVsv(POPs); + PUTBACK; FREETMPS; LEAVE; + if (i) + (void)sv_2mortal(val); + } + + ival = SvRV(val); + flags = SvFLAGS(ival); + realtype = SvTYPE(ival); + (void) sprintf(id, "0x%lx", (unsigned long)ival); + idlen = strlen(id); + if (SvOBJECT(ival)) + realpack = HvNAME(SvSTASH(ival)); + else + realpack = Nullch; + if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) && + (sv = *svp) && SvROK(sv) && + (seenentry = (AV*)SvRV(sv))) { + SV *othername; + if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)) { + if (purity && *levelp > 0) { + SV *postentry; + + if (realtype == SVt_PVHV) + sv_catpvn(retval, "{}", 2); + else if (realtype == SVt_PVAV) + sv_catpvn(retval, "[]", 2); + else + sv_catpvn(retval, "''", 2); + postentry = newSVpv(name, namelen); + sv_catpvn(postentry, " = ", 3); + sv_catsv(postentry, othername); + av_push(postav, postentry); + } + else { + if (name[0] == '@' || name[0] == '%') { + if ((SvPVX(othername))[0] == '\\' && + (SvPVX(othername))[1] == name[0]) { + sv_catpvn(retval, SvPVX(othername)+1, SvCUR(othername)-1); + } + else { + sv_catpvn(retval, name, 1); + sv_catpvn(retval, "{", 1); + sv_catsv(retval, othername); + sv_catpvn(retval, "}", 1); + } + } + else + sv_catsv(retval, othername); + } + return 1; + } + else { + warn("ref name not found for %s", id); + return 0; + } + } + else { /* store our name and continue */ + SV *namesv; + if (name[0] == '@' || name[0] == '%') { + namesv = newSVpv("\\", 1); + sv_catpvn(namesv, name, namelen); + } + else if (realtype == SVt_PVCV && name[0] == '*') { + namesv = newSVpv("\\", 2); + sv_catpvn(namesv, name, namelen); + (SvPVX(namesv))[1] = '&'; + } + else + namesv = newSVpv(name, namelen); + seenentry = newAV(); + av_push(seenentry, namesv); + (void)SvREFCNT_inc(val); + av_push(seenentry, val); + (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0); + SvREFCNT_dec(seenentry); + } + + (*levelp)++; + ipad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp); + + if (realpack) { /* we have a blessed ref */ + STRLEN blesslen; + char *blessstr = SvPV(bless, blesslen); + sv_catpvn(retval, blessstr, blesslen); + sv_catpvn(retval, "( ", 2); + if (indent >= 2) { + blesspad = apad; + apad = newSVsv(apad); + sv_x(apad, " ", 1, blesslen+2); + } + } + + if (realtype <= SVt_PVBM || realtype == SVt_PVGV) { /* scalars */ + if (realpack && realtype != SVt_PVGV) { /* blessed */ + sv_catpvn(retval, "do{\\(my $o = ", 13); + DD_dump(ival, "", 0, retval, seenhv, postav, + levelp, indent, pad, xpad, apad, sep, + freezer, toaster, purity, deepcopy, quotekeys, bless); + sv_catpvn(retval, ")}", 2); + } + else { + sv_catpvn(retval, "\\", 1); + DD_dump(ival, "", 0, retval, seenhv, postav, + levelp, indent, pad, xpad, apad, sep, + freezer, toaster, purity, deepcopy, quotekeys, bless); + } + } + else if (realtype == SVt_PVAV) { + SV *totpad; + I32 ix = 0; + I32 ixmax = av_len((AV *)ival); + + SV *ixsv = newSViv(0); + /* allowing for a 24 char wide array index */ + New(0, iname, namelen+28, char); + (void)strcpy(iname, name); + inamelen = namelen; + if (name[0] == '@') { + sv_catpvn(retval, "(", 1); + iname[0] = '$'; + } + else { + sv_catpvn(retval, "[", 1); + if (namelen > 0 && name[namelen-1] != ']' && name[namelen-1] != '}') { + iname[inamelen++] = '-'; iname[inamelen++] = '>'; + iname[inamelen] = '\0'; + } + } + if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 && + (instr(iname+inamelen-8, "{SCALAR}") || + instr(iname+inamelen-7, "{ARRAY}") || + instr(iname+inamelen-6, "{HASH}"))) { + iname[inamelen++] = '-'; iname[inamelen++] = '>'; + } + iname[inamelen++] = '['; iname[inamelen] = '\0'; + totpad = newSVsv(sep); + sv_catsv(totpad, pad); + sv_catsv(totpad, apad); + + for (ix = 0; ix <= ixmax; ++ix) { + STRLEN ilen; + SV *elem; + svp = av_fetch((AV*)ival, ix, FALSE); + if (svp) + elem = *svp; + else + elem = &PL_sv_undef; + + ilen = inamelen; + sv_setiv(ixsv, ix); + (void) sprintf(iname+ilen, "%ld", ix); + ilen = strlen(iname); + iname[ilen++] = ']'; iname[ilen] = '\0'; + if (indent >= 3) { + sv_catsv(retval, totpad); + sv_catsv(retval, ipad); + sv_catpvn(retval, "#", 1); + sv_catsv(retval, ixsv); + } + sv_catsv(retval, totpad); + sv_catsv(retval, ipad); + DD_dump(elem, iname, ilen, retval, seenhv, postav, + levelp, indent, pad, xpad, apad, sep, + freezer, toaster, purity, deepcopy, quotekeys, bless); + if (ix < ixmax) + sv_catpvn(retval, ",", 1); + } + if (ixmax >= 0) { + SV *opad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1); + sv_catsv(retval, totpad); + sv_catsv(retval, opad); + SvREFCNT_dec(opad); + } + if (name[0] == '@') + sv_catpvn(retval, ")", 1); + else + sv_catpvn(retval, "]", 1); + SvREFCNT_dec(ixsv); + SvREFCNT_dec(totpad); + Safefree(iname); + } + else if (realtype == SVt_PVHV) { + SV *totpad, *newapad; + SV *iname, *sname; + HE *entry; + char *key; + I32 klen; + SV *hval; + + iname = newSVpv(name, namelen); + if (name[0] == '%') { + sv_catpvn(retval, "(", 1); + (SvPVX(iname))[0] = '$'; + } + else { + sv_catpvn(retval, "{", 1); + if (namelen > 0 && name[namelen-1] != ']' && name[namelen-1] != '}') { + sv_catpvn(iname, "->", 2); + } + } + if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 && + (instr(name+namelen-8, "{SCALAR}") || + instr(name+namelen-7, "{ARRAY}") || + instr(name+namelen-6, "{HASH}"))) { + sv_catpvn(iname, "->", 2); + } + sv_catpvn(iname, "{", 1); + totpad = newSVsv(sep); + sv_catsv(totpad, pad); + sv_catsv(totpad, apad); + + (void)hv_iterinit((HV*)ival); + i = 0; + while ((entry = hv_iternext((HV*)ival))) { + char *nkey; + I32 nticks = 0; + + if (i) + sv_catpvn(retval, ",", 1); + i++; + key = hv_iterkey(entry, &klen); + hval = hv_iterval((HV*)ival, entry); + + if (quotekeys || needs_quote(key)) { + nticks = num_q(key, klen); + New(0, nkey, klen+nticks+3, char); + nkey[0] = '\''; + if (nticks) + klen += esc_q(nkey+1, key, klen); + else + (void)Copy(key, nkey+1, klen, char); + nkey[++klen] = '\''; + nkey[++klen] = '\0'; + } + else { + New(0, nkey, klen, char); + (void)Copy(key, nkey, klen, char); + } + + sname = newSVsv(iname); + sv_catpvn(sname, nkey, klen); + sv_catpvn(sname, "}", 1); + + sv_catsv(retval, totpad); + sv_catsv(retval, ipad); + sv_catpvn(retval, nkey, klen); + sv_catpvn(retval, " => ", 4); + if (indent >= 2) { + char *extra; + I32 elen = 0; + newapad = newSVsv(apad); + New(0, extra, klen+4+1, char); + while (elen < (klen+4)) + extra[elen++] = ' '; + extra[elen] = '\0'; + sv_catpvn(newapad, extra, elen); + Safefree(extra); + } + else + newapad = apad; + + DD_dump(hval, SvPVX(sname), SvCUR(sname), retval, seenhv, + postav, levelp, indent, pad, xpad, newapad, sep, + freezer, toaster, purity, deepcopy, quotekeys, bless); + SvREFCNT_dec(sname); + Safefree(nkey); + if (indent >= 2) + SvREFCNT_dec(newapad); + } + if (i) { + SV *opad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1); + sv_catsv(retval, totpad); + sv_catsv(retval, opad); + SvREFCNT_dec(opad); + } + if (name[0] == '%') + sv_catpvn(retval, ")", 1); + else + sv_catpvn(retval, "}", 1); + SvREFCNT_dec(iname); + SvREFCNT_dec(totpad); + } + else if (realtype == SVt_PVCV) { + sv_catpvn(retval, "sub { \"DUMMY\" }", 15); + if (purity) + warn("Encountered CODE ref, using dummy placeholder"); + } + else { + warn("cannot handle ref type %ld", realtype); + } + + if (realpack) { /* free blessed allocs */ + if (indent >= 2) { + SvREFCNT_dec(apad); + apad = blesspad; + } + sv_catpvn(retval, ", '", 3); + sv_catpvn(retval, realpack, strlen(realpack)); + sv_catpvn(retval, "' )", 3); + if (toaster && SvPOK(toaster) && SvCUR(toaster)) { + sv_catpvn(retval, "->", 2); + sv_catsv(retval, toaster); + sv_catpvn(retval, "()", 2); + } + } + SvREFCNT_dec(ipad); + (*levelp)--; + } + else { + STRLEN i; + + if (namelen) { + (void) sprintf(id, "0x%lx", (unsigned long)val); + if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) && + (sv = *svp) && SvROK(sv) && + (seenentry = (AV*)SvRV(sv))) { + SV *othername; + if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)) { + sv_catsv(retval, othername); + return 1; + } + } + else { + SV *namesv; + namesv = newSVpv("\\", 1); + sv_catpvn(namesv, name, namelen); + seenentry = newAV(); + av_push(seenentry, namesv); + (void)SvREFCNT_inc(val); + av_push(seenentry, val); + (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0); + SvREFCNT_dec(seenentry); + } + } + + if (SvIOK(val)) { + STRLEN len; + i = SvIV(val); + (void) sprintf(tmpbuf, "%d", i); + len = strlen(tmpbuf); + sv_catpvn(retval, tmpbuf, len); + return 1; + } + else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */ + c = SvPV(val, i); + ++c; --i; /* just get the name */ + if (i >= 6 && strncmp(c, "main::", 6) == 0) { + c += 4; + i -= 4; + } + if (needs_quote(c)) { + sv_grow(retval, SvCUR(retval)+6+2*i); + r = SvPVX(retval)+SvCUR(retval); + r[0] = '*'; r[1] = '{'; r[2] = '\''; + i += esc_q(r+3, c, i); + i += 3; + r[i++] = '\''; r[i++] = '}'; + r[i] = '\0'; + } + else { + sv_grow(retval, SvCUR(retval)+i+2); + r = SvPVX(retval)+SvCUR(retval); + r[0] = '*'; strcpy(r+1, c); + i++; + } + + if (purity) { + static char *entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" }; + static STRLEN sizes[] = { 8, 7, 6 }; + SV *e; + SV *nname = newSVpv("", 0); + SV *newapad = newSVpv("", 0); + GV *gv = (GV*)val; + I32 j; + + for (j=0; j<3; j++) { + e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv)); + if (e) { + I32 nlevel = 0; + SV *postentry = newSVpv(r,i); + + sv_setsv(nname, postentry); + sv_catpvn(nname, entries[j], sizes[j]); + sv_catpvn(postentry, " = ", 3); + av_push(postav, postentry); + e = newRV(e); + + SvCUR(newapad) = 0; + if (indent >= 2) + (void)sv_x(newapad, " ", 1, SvCUR(postentry)); + + DD_dump(e, SvPVX(nname), SvCUR(nname), postentry, + seenhv, postav, &nlevel, indent, pad, xpad, + newapad, sep, freezer, toaster, purity, + deepcopy, quotekeys, bless); + SvREFCNT_dec(e); + } + } + + SvREFCNT_dec(newapad); + SvREFCNT_dec(nname); + } + } + else { + c = SvPV(val, i); + sv_grow(retval, SvCUR(retval)+3+2*i); + r = SvPVX(retval)+SvCUR(retval); + r[0] = '\''; + i += esc_q(r+1, c, i); + ++i; + r[i++] = '\''; + r[i] = '\0'; + } + SvCUR_set(retval, SvCUR(retval)+i); + } + + if (deepcopy && idlen) + (void)hv_delete(seenhv, id, idlen, G_DISCARD); + + return 1; +} + + +MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_ + +# +# This is the exact equivalent of Dump. Well, almost. The things that are +# different as of now (due to Laziness): +# * doesnt do double-quotes yet. +# + +void +Data_Dumper_Dumpxs(href, ...) + SV *href; + PROTOTYPE: $;$$ + PPCODE: + { + HV *hv; + SV *retval, *valstr; + HV *seenhv = Nullhv; + AV *postav, *todumpav, *namesav; + I32 level = 0; + I32 indent, terse, useqq, i, imax, postlen; + SV **svp; + SV *val, *name, *pad, *xpad, *apad, *sep, *tmp, *varname; + SV *freezer, *toaster, *bless; + I32 purity, deepcopy, quotekeys; + char tmpbuf[1024]; + I32 gimme = GIMME; + + if (!SvROK(href)) { /* call new to get an object first */ + SV *valarray; + SV *namearray; + + if (items == 3) { + valarray = ST(1); + namearray = ST(2); + } + else + croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, NAME_ARY_REF)"); + + ENTER; + SAVETMPS; + + PUSHMARK(sp); + XPUSHs(href); + XPUSHs(sv_2mortal(newSVsv(valarray))); + XPUSHs(sv_2mortal(newSVsv(namearray))); + PUTBACK; + i = perl_call_method("new", G_SCALAR); + SPAGAIN; + if (i) + href = newSVsv(POPs); + + PUTBACK; + FREETMPS; + LEAVE; + if (i) + (void)sv_2mortal(href); + } + + todumpav = namesav = Nullav; + seenhv = Nullhv; + val = pad = xpad = apad = sep = tmp = varname + = freezer = toaster = bless = &PL_sv_undef; + name = sv_newmortal(); + indent = 2; + terse = useqq = purity = deepcopy = 0; + quotekeys = 1; + + retval = newSVpv("", 0); + if (SvROK(href) + && (hv = (HV*)SvRV((SV*)href)) + && SvTYPE(hv) == SVt_PVHV) { + + if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp)) + seenhv = (HV*)SvRV(*svp); + if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp)) + todumpav = (AV*)SvRV(*svp); + if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp)) + namesav = (AV*)SvRV(*svp); + if ((svp = hv_fetch(hv, "indent", 6, FALSE))) + indent = SvIV(*svp); + if ((svp = hv_fetch(hv, "purity", 6, FALSE))) + purity = SvIV(*svp); + if ((svp = hv_fetch(hv, "terse", 5, FALSE))) + terse = SvTRUE(*svp); + if ((svp = hv_fetch(hv, "useqq", 5, FALSE))) + useqq = SvTRUE(*svp); + if ((svp = hv_fetch(hv, "pad", 3, FALSE))) + pad = *svp; + if ((svp = hv_fetch(hv, "xpad", 4, FALSE))) + xpad = *svp; + if ((svp = hv_fetch(hv, "apad", 4, FALSE))) + apad = *svp; + if ((svp = hv_fetch(hv, "sep", 3, FALSE))) + sep = *svp; + if ((svp = hv_fetch(hv, "varname", 7, FALSE))) + varname = *svp; + if ((svp = hv_fetch(hv, "freezer", 7, FALSE))) + freezer = *svp; + if ((svp = hv_fetch(hv, "toaster", 7, FALSE))) + toaster = *svp; + if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE))) + deepcopy = SvTRUE(*svp); + if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE))) + quotekeys = SvTRUE(*svp); + if ((svp = hv_fetch(hv, "bless", 5, FALSE))) + bless = *svp; + postav = newAV(); + + if (todumpav) + imax = av_len(todumpav); + else + imax = -1; + valstr = newSVpv("",0); + for (i = 0; i <= imax; ++i) { + SV *newapad; + + av_clear(postav); + if ((svp = av_fetch(todumpav, i, FALSE))) + val = *svp; + else + val = &PL_sv_undef; + if ((svp = av_fetch(namesav, i, TRUE))) + sv_setsv(name, *svp); + else + SvOK_off(name); + + if (SvOK(name)) { + if ((SvPVX(name))[0] == '*') { + if (SvROK(val)) { + switch (SvTYPE(SvRV(val))) { + case SVt_PVAV: + (SvPVX(name))[0] = '@'; + break; + case SVt_PVHV: + (SvPVX(name))[0] = '%'; + break; + case SVt_PVCV: + (SvPVX(name))[0] = '*'; + break; + default: + (SvPVX(name))[0] = '$'; + break; + } + } + else + (SvPVX(name))[0] = '$'; + } + else if ((SvPVX(name))[0] != '$') + sv_insert(name, 0, 0, "$", 1); + } + else { + STRLEN nchars = 0; + sv_setpvn(name, "$", 1); + sv_catsv(name, varname); + (void) sprintf(tmpbuf, "%ld", i+1); + nchars = strlen(tmpbuf); + sv_catpvn(name, tmpbuf, nchars); + } + + if (indent >= 2) { + SV *tmpsv = sv_x(Nullsv, " ", 1, SvCUR(name)+3); + newapad = newSVsv(apad); + sv_catsv(newapad, tmpsv); + SvREFCNT_dec(tmpsv); + } + else + newapad = apad; + + DD_dump(val, SvPVX(name), SvCUR(name), valstr, seenhv, + postav, &level, indent, pad, xpad, newapad, sep, + freezer, toaster, purity, deepcopy, quotekeys, + bless); + + if (indent >= 2) + SvREFCNT_dec(newapad); + + postlen = av_len(postav); + if (postlen >= 0 || !terse) { + sv_insert(valstr, 0, 0, " = ", 3); + sv_insert(valstr, 0, 0, SvPVX(name), SvCUR(name)); + sv_catpvn(valstr, ";", 1); + } + sv_catsv(retval, pad); + sv_catsv(retval, valstr); + sv_catsv(retval, sep); + if (postlen >= 0) { + I32 i; + sv_catsv(retval, pad); + for (i = 0; i <= postlen; ++i) { + SV *elem; + svp = av_fetch(postav, i, FALSE); + if (svp && (elem = *svp)) { + sv_catsv(retval, elem); + if (i < postlen) { + sv_catpvn(retval, ";", 1); + sv_catsv(retval, sep); + sv_catsv(retval, pad); + } + } + } + sv_catpvn(retval, ";", 1); + sv_catsv(retval, sep); + } + sv_setpvn(valstr, "", 0); + if (gimme == G_ARRAY) { + XPUSHs(sv_2mortal(retval)); + if (i < imax) /* not the last time thro ? */ + retval = newSVpv("",0); + } + } + SvREFCNT_dec(postav); + SvREFCNT_dec(valstr); + } + else + croak("Call to new() method failed to return HASH ref"); + if (gimme == G_SCALAR) + XPUSHs(sv_2mortal(retval)); + } diff --git a/contrib/perl5/ext/Data/Dumper/Makefile.PL b/contrib/perl5/ext/Data/Dumper/Makefile.PL new file mode 100644 index 0000000..6c94e95d --- /dev/null +++ b/contrib/perl5/ext/Data/Dumper/Makefile.PL @@ -0,0 +1,11 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => "Data::Dumper", + VERSION_FROM => 'Dumper.pm', + 'dist' => { + COMPRESS => 'gzip -9f', + SUFFIX => 'gz', + DIST_DEFAULT => 'all tardist', + }, + MAN3PODS => ' ', +); diff --git a/contrib/perl5/ext/Data/Dumper/Todo b/contrib/perl5/ext/Data/Dumper/Todo new file mode 100644 index 0000000..4a41f97 --- /dev/null +++ b/contrib/perl5/ext/Data/Dumper/Todo @@ -0,0 +1,32 @@ +=head1 NAME + +TODO - seeds germane, yet not germinated + +=head1 DESCRIPTION + +The following functionality will be supported in the next few releases. + +=over 4 + +=item $Data::Dumper::Maxdepth I $I->Maxdepth(I) + +Depth beyond which we don't venture into a structure. Has no effect when +C is set. (useful in debugger when we often don't +want to see more than enough). + +=item $Data::Dumper::Expdepth I $I->Expdepth(I) + +Dump contents explicitly up to a certain depth and then use names for +cross-referencing identical references. (useful in debugger, in situations +where we don't care so much for cross-references). + +=item Make C honor C<$Useqq> + +=item Fix formatting when Terse is set and Indent >= 2 + +=item Output space after '\' (ref constructor) for high enough Indent + +=item Implement redesign that allows various backends (Perl, Lisp, +some-binary-data-format, graph-description-languages, etc.) + +=back diff --git a/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL b/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL new file mode 100644 index 0000000..4c41559 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL @@ -0,0 +1,729 @@ + +use Config; + +sub to_string { + my ($value) = @_; + $value =~ s/\\/\\\\'/g; + $value =~ s/'/\\'/g; + return "'$value'"; +} + +unlink "DynaLoader.pm" if -f "DynaLoader.pm"; +open OUT, ">DynaLoader.pm" or die $!; +print OUT <<'EOT'; + +# Generated from DynaLoader.pm.PL (resolved %Config::Config values) + +package DynaLoader; + +# And Gandalf said: 'Many folk like to know beforehand what is to +# be set on the table; but those who have laboured to prepare the +# feast like to keep their secret; for wonder makes the words of +# praise louder.' + +# (Quote from Tolkien sugested by Anno Siegel.) +# +# See pod text at end of file for documentation. +# See also ext/DynaLoader/README in source tree for other information. +# +# Tim.Bunce@ig.co.uk, August 1994 + +$VERSION = $VERSION = "1.03"; # avoid typo warning + +require AutoLoader; +*AUTOLOAD = \&AutoLoader::AUTOLOAD; + +# The following require can't be removed during maintenance +# releases, sadly, because of the risk of buggy code that does +# require Carp; Carp::croak "..."; without brackets dying +# if Carp hasn't been loaded in earlier compile time. :-( +# We'll let those bugs get found on the development track. +require Carp if $] < 5.00450; + + +# enable debug/trace messages from DynaLoader perl code +$dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; + +# +# Flags to alter dl_load_file behaviour. Assigned bits: +# 0x01 make symbols available for linking later dl_load_file's. +# (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL)) +# (ignored under VMS; effect is built-in to image linking) +# +# This is called as a class method $module->dl_load_flags. The +# definition here will be inherited and result on "default" loading +# behaviour unless a sub-class of DynaLoader defines its own version. +# + +sub dl_load_flags { 0x00 } + +# ($dl_dlext, $dlsrc) +# = @Config::Config{'dlext', 'dlsrc'}; +EOT + +print OUT " (\$dl_dlext, \$dlsrc) = (", + to_string($Config::Config{'dlext'}), ",", + to_string($Config::Config{'dlsrc'}), ")\n;" ; + +print OUT <<'EOT'; + +# Some systems need special handling to expand file specifications +# (VMS support by Charles Bailey ) +# See dl_expandspec() for more details. Should be harmless but +# inefficient to define on systems that don't need it. +$do_expand = $Is_VMS = $^O eq 'VMS'; + +@dl_require_symbols = (); # names of symbols we need +@dl_resolve_using = (); # names of files to link with +@dl_library_path = (); # path to look for files +@dl_librefs = (); # things we have loaded +@dl_modules = (); # Modules we have loaded + +# This is a fix to support DLD's unfortunate desire to relink -lc +@dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs"; + +# Initialise @dl_library_path with the 'standard' library path +# for this platform as determined by Configure + +# push(@dl_library_path, split(' ', $Config::Config{'libpth'}); +EOT + +print OUT "push(\@dl_library_path, split(' ', ", + to_string($Config::Config{'libpth'}), "));\n"; + +print OUT <<'EOT'; + +# Add to @dl_library_path any extra directories we can gather from +# environment variables. So far LD_LIBRARY_PATH is the only known +# variable used for this purpose. Others may be added later. +push(@dl_library_path, split(/:/, $ENV{LD_LIBRARY_PATH})) + if $ENV{LD_LIBRARY_PATH}; + + +# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. +boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader); + + +if ($dl_debug) { + print STDERR "DynaLoader.pm loaded (@INC, @dl_library_path)\n"; + print STDERR "DynaLoader not linked into this perl\n" + unless defined(&boot_DynaLoader); +} + +1; # End of main code + + +sub croak { require Carp; Carp::croak(@_) } + +# The bootstrap function cannot be autoloaded (without complications) +# so we define it here: + +sub bootstrap { + # use local vars to enable $module.bs script to edit values + local(@args) = @_; + local($module) = $args[0]; + local(@dirs, $file); + + unless ($module) { + require Carp; + Carp::confess("Usage: DynaLoader::bootstrap(module)"); + } + + # A common error on platforms which don't support dynamic loading. + # Since it's fatal and potentially confusing we give a detailed message. + croak("Can't load module $module, dynamic loading not available in this perl.\n". + " (You may need to build a new perl executable which either supports\n". + " dynamic loading or has the $module module statically linked into it.)\n") + unless defined(&dl_load_file); + + my @modparts = split(/::/,$module); + my $modfname = $modparts[-1]; + + # Some systems have restrictions on files names for DLL's etc. + # mod2fname returns appropriate file base name (typically truncated) + # It may also edit @modparts if required. + $modfname = &mod2fname(\@modparts) if defined &mod2fname; + + my $modpname = join('/',@modparts); + + print STDERR "DynaLoader::bootstrap for $module ", + "(auto/$modpname/$modfname.$dl_dlext)\n" if $dl_debug; + + foreach (@INC) { + chop($_ = VMS::Filespec::unixpath($_)) if $Is_VMS; + my $dir = "$_/auto/$modpname"; + next unless -d $dir; # skip over uninteresting directories + + # check for common cases to avoid autoload of dl_findfile + my $try = "$dir/$modfname.$dl_dlext"; + last if $file = ($do_expand) ? dl_expandspec($try) : (-f $try && $try); + + # no luck here, save dir for possible later dl_findfile search + push @dirs, $dir; + } + # last resort, let dl_findfile have a go in all known locations + $file = dl_findfile(map("-L$_",@dirs,@INC), $modfname) unless $file; + + croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)") + unless $file; # wording similar to error from 'require' + + my $bootname = "boot_$module"; + $bootname =~ s/\W/_/g; + @dl_require_symbols = ($bootname); + + # Execute optional '.bootstrap' perl script for this module. + # The .bs file can be used to configure @dl_resolve_using etc to + # match the needs of the individual module on this architecture. + my $bs = $file; + $bs =~ s/(\.\w+)?$/\.bs/; # look for .bs 'beside' the library + if (-s $bs) { # only read file if it's not empty + print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug; + eval { do $bs; }; + warn "$bs: $@\n" if $@; + } + + # Many dynamic extension loading problems will appear to come from + # this section of code: XYZ failed at line 123 of DynaLoader.pm. + # Often these errors are actually occurring in the initialisation + # C code of the extension XS file. Perl reports the error as being + # in this perl code simply because this was the last perl code + # it executed. + + my $libref = dl_load_file($file, $module->dl_load_flags) or + croak("Can't load '$file' for module $module: ".dl_error()."\n"); + + push(@dl_librefs,$libref); # record loaded object + + my @unresolved = dl_undef_symbols(); + if (@unresolved) { + require Carp; + Carp::carp("Undefined symbols present after loading $file: @unresolved\n"); + } + + my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or + croak("Can't find '$bootname' symbol in $file\n"); + + my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); + + push(@dl_modules, $module); # record loaded module + + # See comment block above + &$xs(@args); +} + + +#sub _check_file { # private utility to handle dl_expandspec vs -f tests +# my($file) = @_; +# return $file if (!$do_expand && -f $file); # the common case +# return $file if ( $do_expand && ($file=dl_expandspec($file))); +# return undef; +#} + + +# Let autosplit and the autoloader deal with these functions: +__END__ + + +sub dl_findfile { + # Read ext/DynaLoader/DynaLoader.doc for detailed information. + # This function does not automatically consider the architecture + # or the perl library auto directories. + my (@args) = @_; + my (@dirs, $dir); # which directories to search + my (@found); # full paths to real files we have found +EOT + +print OUT ' my $dl_ext= ' . to_string($Config::Config{'dlext'}) . + "; # \$Config::Config{'dlext'} suffix for perl extensions\n"; +print OUT ' my $dl_so = ' . to_string($Config::Config{'so'}) . + "; # \$Config::Config{'so'} suffix for shared libraries\n"; + +print OUT <<'EOT'; + + print STDERR "dl_findfile(@args)\n" if $dl_debug; + + # accumulate directories but process files as they appear + arg: foreach(@args) { + # Special fast case: full filepath requires no search + if ($Is_VMS && m%[:>/\]]% && -f $_) { + push(@found,dl_expandspec(VMS::Filespec::vmsify($_))); + last arg unless wantarray; + next; + } + elsif (m:/: && -f $_ && !$do_expand) { + push(@found,$_); + last arg unless wantarray; + next; + } + + # Deal with directories first: + # Using a -L prefix is the preferred option (faster and more robust) + if (m:^-L:) { s/^-L//; push(@dirs, $_); next; } + + # Otherwise we try to try to spot directories by a heuristic + # (this is a more complicated issue than it first appears) + if (m:/: && -d $_) { push(@dirs, $_); next; } + + # VMS: we may be using native VMS directry syntax instead of + # Unix emulation, so check this as well + if ($Is_VMS && /[:>\]]/ && -d $_) { push(@dirs, $_); next; } + + # Only files should get this far... + my(@names, $name); # what filenames to look for + if (m:-l: ) { # convert -lname to appropriate library name + s/-l//; + push(@names,"lib$_.$dl_so"); + push(@names,"lib$_.a"); + } else { # Umm, a bare name. Try various alternatives: + # these should be ordered with the most likely first + push(@names,"$_.$dl_ext") unless m/\.$dl_ext$/o; + push(@names,"$_.$dl_so") unless m/\.$dl_so$/o; + push(@names,"lib$_.$dl_so") unless m:/:; + push(@names,"$_.a") if !m/\.a$/ and $dlsrc eq "dl_dld.xs"; + push(@names, $_); + } + foreach $dir (@dirs, @dl_library_path) { + next unless -d $dir; + chop($dir = VMS::Filespec::unixpath($dir)) if $Is_VMS; + foreach $name (@names) { + my($file) = "$dir/$name"; + print STDERR " checking in $dir for $name\n" if $dl_debug; + $file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file); + #$file = _check_file($file); + if ($file) { + push(@found, $file); + next arg; # no need to look any further + } + } + } + } + if ($dl_debug) { + foreach(@dirs) { + print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_; + } + print STDERR "dl_findfile found: @found\n"; + } + return $found[0] unless wantarray; + @found; +} + + +sub dl_expandspec { + my($spec) = @_; + # Optional function invoked if DynaLoader.pm sets $do_expand. + # Most systems do not require or use this function. + # Some systems may implement it in the dl_*.xs file in which case + # this autoload version will not be called but is harmless. + + # This function is designed to deal with systems which treat some + # 'filenames' in a special way. For example VMS 'Logical Names' + # (something like unix environment variables - but different). + # This function should recognise such names and expand them into + # full file paths. + # Must return undef if $spec is invalid or file does not exist. + + my $file = $spec; # default output to input + + if ($Is_VMS) { # dl_expandspec should be defined in dl_vms.xs + require Carp; + Carp::croak("dl_expandspec: should be defined in XS file!\n"); + } else { + return undef unless -f $file; + } + print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug; + $file; +} + +sub dl_find_symbol_anywhere +{ + my $sym = shift; + my $libref; + foreach $libref (@dl_librefs) { + my $symref = dl_find_symbol($libref,$sym); + return $symref if $symref; + } + return undef; +} + +=head1 NAME + +DynaLoader - Dynamically load C libraries into Perl code + +dl_error(), dl_findfile(), dl_expandspec(), dl_load_file(), dl_find_symbol(), dl_find_symbol_anywhere(), dl_undef_symbols(), dl_install_xsub(), dl_load_flags(), bootstrap() - routines used by DynaLoader modules + +=head1 SYNOPSIS + + package YourPackage; + require DynaLoader; + @ISA = qw(... DynaLoader ...); + bootstrap YourPackage; + + # optional method for 'global' loading + sub dl_load_flags { 0x01 } + + +=head1 DESCRIPTION + +This document defines a standard generic interface to the dynamic +linking mechanisms available on many platforms. Its primary purpose is +to implement automatic dynamic loading of Perl modules. + +This document serves as both a specification for anyone wishing to +implement the DynaLoader for a new platform and as a guide for +anyone wishing to use the DynaLoader directly in an application. + +The DynaLoader is designed to be a very simple high-level +interface that is sufficiently general to cover the requirements +of SunOS, HP-UX, NeXT, Linux, VMS and other platforms. + +It is also hoped that the interface will cover the needs of OS/2, NT +etc and also allow pseudo-dynamic linking (using C at runtime). + +It must be stressed that the DynaLoader, by itself, is practically +useless for accessing non-Perl libraries because it provides almost no +Perl-to-C 'glue'. There is, for example, no mechanism for calling a C +library function or supplying arguments. A C::DynaLib module +is available from CPAN sites which performs that function for some +common system types. + +DynaLoader Interface Summary + + @dl_library_path + @dl_resolve_using + @dl_require_symbols + $dl_debug + @dl_librefs + @dl_modules + Implemented in: + bootstrap($modulename) Perl + @filepaths = dl_findfile(@names) Perl + $flags = $modulename->dl_load_flags Perl + $symref = dl_find_symbol_anywhere($symbol) Perl + + $libref = dl_load_file($filename, $flags) C + $symref = dl_find_symbol($libref, $symbol) C + @symbols = dl_undef_symbols() C + dl_install_xsub($name, $symref [, $filename]) C + $message = dl_error C + +=over 4 + +=item @dl_library_path + +The standard/default list of directories in which dl_findfile() will +search for libraries etc. Directories are searched in order: +$dl_library_path[0], [1], ... etc + +@dl_library_path is initialised to hold the list of 'normal' directories +(F, etc) determined by B (C<$Config{'libpth'}>). This should +ensure portability across a wide range of platforms. + +@dl_library_path should also be initialised with any other directories +that can be determined from the environment at runtime (such as +LD_LIBRARY_PATH for SunOS). + +After initialisation @dl_library_path can be manipulated by an +application using push and unshift before calling dl_findfile(). +Unshift can be used to add directories to the front of the search order +either to save search time or to override libraries with the same name +in the 'normal' directories. + +The load function that dl_load_file() calls may require an absolute +pathname. The dl_findfile() function and @dl_library_path can be +used to search for and return the absolute pathname for the +library/object that you wish to load. + +=item @dl_resolve_using + +A list of additional libraries or other shared objects which can be +used to resolve any undefined symbols that might be generated by a +later call to load_file(). + +This is only required on some platforms which do not handle dependent +libraries automatically. For example the Socket Perl extension +library (F) contains references to many socket +functions which need to be resolved when it's loaded. Most platforms +will automatically know where to find the 'dependent' library (e.g., +F). A few platforms need to be told the +location of the dependent library explicitly. Use @dl_resolve_using +for this. + +Example usage: + + @dl_resolve_using = dl_findfile('-lsocket'); + +=item @dl_require_symbols + +A list of one or more symbol names that are in the library/object file +to be dynamically loaded. This is only required on some platforms. + +=item @dl_librefs + +An array of the handles returned by successful calls to dl_load_file(), +made by bootstrap, in the order in which they were loaded. +Can be used with dl_find_symbol() to look for a symbol in any of +the loaded files. + +=item @dl_modules + +An array of module (package) names that have been bootstrap'ed. + +=item dl_error() + +Syntax: + + $message = dl_error(); + +Error message text from the last failed DynaLoader function. Note +that, similar to errno in unix, a successful function call does not +reset this message. + +Implementations should detect the error as soon as it occurs in any of +the other functions and save the corresponding message for later +retrieval. This will avoid problems on some platforms (such as SunOS) +where the error message is very temporary (e.g., dlerror()). + +=item $dl_debug + +Internal debugging messages are enabled when $dl_debug is set true. +Currently setting $dl_debug only affects the Perl side of the +DynaLoader. These messages should help an application developer to +resolve any DynaLoader usage problems. + +$dl_debug is set to C<$ENV{'PERL_DL_DEBUG'}> if defined. + +For the DynaLoader developer/porter there is a similar debugging +variable added to the C code (see dlutils.c) and enabled if Perl was +built with the B<-DDEBUGGING> flag. This can also be set via the +PERL_DL_DEBUG environment variable. Set to 1 for minimal information or +higher for more. + +=item dl_findfile() + +Syntax: + + @filepaths = dl_findfile(@names) + +Determine the full paths (including file suffix) of one or more +loadable files given their generic names and optionally one or more +directories. Searches directories in @dl_library_path by default and +returns an empty list if no files were found. + +Names can be specified in a variety of platform independent forms. Any +names in the form B<-lname> are converted into F, where F<.*> is +an appropriate suffix for the platform. + +If a name does not already have a suitable prefix and/or suffix then +the corresponding file will be searched for by trying combinations of +prefix and suffix appropriate to the platform: "$name.o", "lib$name.*" +and "$name". + +If any directories are included in @names they are searched before +@dl_library_path. Directories may be specified as B<-Ldir>. Any other +names are treated as filenames to be searched for. + +Using arguments of the form C<-Ldir> and C<-lname> is recommended. + +Example: + + @dl_resolve_using = dl_findfile(qw(-L/usr/5lib -lposix)); + + +=item dl_expandspec() + +Syntax: + + $filepath = dl_expandspec($spec) + +Some unusual systems, such as VMS, require special filename handling in +order to deal with symbolic names for files (i.e., VMS's Logical Names). + +To support these systems a dl_expandspec() function can be implemented +either in the F file or code can be added to the autoloadable +dl_expandspec() function in F. See F for +more information. + +=item dl_load_file() + +Syntax: + + $libref = dl_load_file($filename, $flags) + +Dynamically load $filename, which must be the path to a shared object +or library. An opaque 'library reference' is returned as a handle for +the loaded object. Returns undef on error. + +The $flags argument to alters dl_load_file behaviour. +Assigned bits: + + 0x01 make symbols available for linking later dl_load_file's. + (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL)) + (ignored under VMS; this is a normal part of image linking) + +(On systems that provide a handle for the loaded object such as SunOS +and HPUX, $libref will be that handle. On other systems $libref will +typically be $filename or a pointer to a buffer containing $filename. +The application should not examine or alter $libref in any way.) + +This is the function that does the real work. It should use the +current values of @dl_require_symbols and @dl_resolve_using if required. + + SunOS: dlopen($filename) + HP-UX: shl_load($filename) + Linux: dld_create_reference(@dl_require_symbols); dld_link($filename) + NeXT: rld_load($filename, @dl_resolve_using) + VMS: lib$find_image_symbol($filename,$dl_require_symbols[0]) + +(The dlopen() function is also used by Solaris and some versions of +Linux, and is a common choice when providing a "wrapper" on other +mechanisms as is done in the OS/2 port.) + +=item dl_loadflags() + +Syntax: + + $flags = dl_loadflags $modulename; + +Designed to be a method call, and to be overridden by a derived class +(i.e. a class which has DynaLoader in its @ISA). The definition in +DynaLoader itself returns 0, which produces standard behavior from +dl_load_file(). + +=item dl_find_symbol() + +Syntax: + + $symref = dl_find_symbol($libref, $symbol) + +Return the address of the symbol $symbol or C if not found. If the +target system has separate functions to search for symbols of different +types then dl_find_symbol() should search for function symbols first and +then other types. + +The exact manner in which the address is returned in $symref is not +currently defined. The only initial requirement is that $symref can +be passed to, and understood by, dl_install_xsub(). + + SunOS: dlsym($libref, $symbol) + HP-UX: shl_findsym($libref, $symbol) + Linux: dld_get_func($symbol) and/or dld_get_symbol($symbol) + NeXT: rld_lookup("_$symbol") + VMS: lib$find_image_symbol($libref,$symbol) + + +=item dl_find_symbol_anywhere() + +Syntax: + + $symref = dl_find_symbol_anywhere($symbol) + +Applies dl_find_symbol() to the members of @dl_librefs and returns +the first match found. + +=item dl_undef_symbols() + +Example + + @symbols = dl_undef_symbols() + +Return a list of symbol names which remain undefined after load_file(). +Returns C<()> if not known. Don't worry if your platform does not provide +a mechanism for this. Most do not need it and hence do not provide it, +they just return an empty list. + + +=item dl_install_xsub() + +Syntax: + + dl_install_xsub($perl_name, $symref [, $filename]) + +Create a new Perl external subroutine named $perl_name using $symref as +a pointer to the function which implements the routine. This is simply +a direct call to newXSUB(). Returns a reference to the installed +function. + +The $filename parameter is used by Perl to identify the source file for +the function if required by die(), caller() or the debugger. If +$filename is not defined then "DynaLoader" will be used. + + +=item bootstrap() + +Syntax: + +bootstrap($module) + +This is the normal entry point for automatic dynamic loading in Perl. + +It performs the following actions: + +=over 8 + +=item * + +locates an auto/$module directory by searching @INC + +=item * + +uses dl_findfile() to determine the filename to load + +=item * + +sets @dl_require_symbols to C<("boot_$module")> + +=item * + +executes an F file if it exists +(typically used to add to @dl_resolve_using any files which +are required to load the module on the current platform) + +=item * + +calls dl_load_flags() to determine how to load the file. + +=item * + +calls dl_load_file() to load the file + +=item * + +calls dl_undef_symbols() and warns if any symbols are undefined + +=item * + +calls dl_find_symbol() for "boot_$module" + +=item * + +calls dl_install_xsub() to install it as "${module}::bootstrap" + +=item * + +calls &{"${module}::bootstrap"} to bootstrap the module (actually +it uses the function reference returned by dl_install_xsub for speed) + +=back + +=back + + +=head1 AUTHOR + +Tim Bunce, 11 August 1994. + +This interface is based on the work and comments of (in no particular +order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno +Siegel, Thomas Neumann, Paul Marquess, Charles Bailey, myself and others. + +Larry Wall designed the elegant inherited bootstrap mechanism and +implemented the first Perl 5 dynamic loader using it. + +Solaris global loading added by Nick Ing-Simmons with design/coding +assistance from Tim Bunce, January 1996. + +=cut +EOT + +close OUT or die $!; + diff --git a/contrib/perl5/ext/DynaLoader/Makefile.PL b/contrib/perl5/ext/DynaLoader/Makefile.PL new file mode 100644 index 0000000..7a75115 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/Makefile.PL @@ -0,0 +1,29 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'DynaLoader', + LINKTYPE => 'static', + DEFINE => '-DPERL_CORE -DLIBC="$(LIBC)"', + MAN3PODS => ' ', # Pods will be built by installman. + SKIP => [qw(dynamic dynamic_lib dynamic_bs)], + XSPROTOARG => '-noprototypes', # XXX remove later? + VERSION_FROM => 'DynaLoader_pm.PL', + PL_FILES => {'DynaLoader_pm.PL'=>'DynaLoader.pm'}, + PM => {'DynaLoader.pm' => '$(INST_LIBDIR)/DynaLoader.pm'}, + clean => {FILES => 'DynaLoader.c DynaLoader.xs DynaLoader.pm'}, +); + +sub MY::postamble { + ' +DynaLoader.xs: $(DLSRC) + $(CP) $? $@ + +# Perform very simple tests just to check for major gaffs. +# We can\'t do much more for platforms we are not executing on. +test-xs: + for i in dl_*xs; \ + do $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSUBPPARGS) $$i > /dev/null; \ + done +'; +} + diff --git a/contrib/perl5/ext/DynaLoader/README b/contrib/perl5/ext/DynaLoader/README new file mode 100644 index 0000000..0551cf3 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/README @@ -0,0 +1,53 @@ +Perl 5 DynaLoader + +See DynaLoader.pm for detailed specification. + +This module is very similar to the other Perl 5 modules except that +Configure selects which dl_*.xs file to use. + +After Configure has been run the Makefile.PL will generate a Makefile +which will run xsubpp on a specific dl_*.xs file and write the output +to DynaLoader.c + +After that the processing is the same as any other module. + +Note that, to be effective, the DynaLoader module must be _statically_ +linked into perl! Configure should arrange this. + +This interface is based on the work and comments of (in no particular +order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno +Siegel, Thomas Neumann, Paul Marquess, Charles Bailey and others. + +The dl_*.xs files should either be named after the dynamic linking +operating system interface used if that interface is available on more +than one type of system, e.g.: + dlopen for dlopen()/dlsym() type functions (SunOS, BSD) + dld for the GNU dld library functions (linux, ?) +or else the osname, e.g., hpux, next, vms etc. + +Both are determined by Configure and so only those specific names that +Configure knows/uses will work. + +If porting the DynaLoader to a platform that has a core dynamic linking +interface similar to an existing generic type, e.g., dlopen or dld, +please try to port the corresponding dl_*.xs file (using #ifdef's if +required). + +Otherwise, or if that proves too messy, create a new dl_*.xs file named +after your osname. Configure will give preference to a dl_$osname.xs +file if one exists. + +The file dl_dlopen.xs is a reference implementation by Paul Marquess +which is a good place to start if porting from scratch. For more complex +platforms take a look at dl_dld.xs. The dlutils.c file holds some +common definitions that are #included into the dl_*.xs files. + +After the initial implementation of a new DynaLoader dl_*.xs file you +may need to edit or create ext/MODULE/MODULE.bs files (library bootstrap +files) to reflect the needs of your platform and linking software. + +Refer to DynaLoader.pm, lib/ExtUtils/MakeMaker.pm and any existing +ext/MODULE/MODULE.bs files for more information. + +Tim Bunce. +August 1994 diff --git a/contrib/perl5/ext/DynaLoader/dl_aix.xs b/contrib/perl5/ext/DynaLoader/dl_aix.xs new file mode 100644 index 0000000..ea50408 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_aix.xs @@ -0,0 +1,670 @@ +/* dl_aix.xs + * + * Written: 8/31/94 by Wayne Scott (wscott@ichips.intel.com) + * + * All I did was take Jens-Uwe Mager's libdl emulation library for + * AIX and merged it with the dl_dlopen.xs file to create a dynamic library + * package that works for AIX. + * + * I did change all malloc's, free's, strdup's, calloc's to use the perl + * equilvant. I also removed some stuff we will not need. Call fini() + * on statup... It can probably be trimmed more. + */ + +/* + * @(#)dlfcn.c 1.5 revision of 93/02/14 20:14:17 + * This is an unpublished work copyright (c) 1992 Helios Software GmbH + * 3000 Hannover 1, Germany + */ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include +#include +#include +#include +#include +#include +#include +#include + +/* + * AIX 4.3 does remove some useful definitions from ldfcn.h. Define + * these here to compensate for that lossage. + */ +#ifndef BEGINNING +# define BEGINNING SEEK_SET +#endif +#ifndef FSEEK +# define FSEEK(ldptr,o,p) fseek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr) +o):o,p) +#endif +#ifndef FREAD +# define FREAD(p,s,n,ldptr) fread(p,s,n,IOPTR(ldptr)) +#endif + +/* If using PerlIO, redefine these macros from */ +#ifdef USE_PERLIO +#define FSEEK(ldptr,o,p) PerlIO_seek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr)+o):o,p) +#define FREAD(p,s,n,ldptr) PerlIO_read(IOPTR(ldptr),p,s*n) +#endif + +/* + * We simulate dlopen() et al. through a call to load. Because AIX has + * no call to find an exported symbol we read the loader section of the + * loaded module and build a list of exported symbols and their virtual + * address. + */ + +typedef struct { + char *name; /* the symbols's name */ + void *addr; /* its relocated virtual address */ +} Export, *ExportPtr; + +/* + * The void * handle returned from dlopen is actually a ModulePtr. + */ +typedef struct Module { + struct Module *next; + char *name; /* module name for refcounting */ + int refCnt; /* the number of references */ + void *entry; /* entry point from load */ + int nExports; /* the number of exports found */ + ExportPtr exports; /* the array of exports */ +} Module, *ModulePtr; + +/* + * We keep a list of all loaded modules to be able to call the fini + * handlers at atexit() time. + */ +static ModulePtr modList; + +/* + * The last error from one of the dl* routines is kept in static + * variables here. Each error is returned only once to the caller. + */ +static char errbuf[BUFSIZ]; +static int errvalid; + +static void caterr(char *); +static int readExports(ModulePtr); +static void terminate(void); +static void *findMain(void); + +static char *strerror_failed = "(strerror failed)"; +static char *strerror_r_failed = "(strerror_r failed)"; + +char *strerrorcat(char *str, int err) { + int strsiz = strlen(str); + int msgsiz; + char *msg; + +#ifdef USE_THREADS + char *buf = malloc(BUFSIZ); + + if (buf == 0) + return 0; + if (strerror_r(err, buf, sizeof(buf)) == 0) + msg = buf; + else + msg = strerror_r_failed; + msgsiz = strlen(msg); + if (strsiz + msgsiz < BUFSIZ) + strcat(str, msg); + free(buf); +#else + if ((msg = strerror(err)) == 0) + msg = strerror_failed; + msgsiz = strlen(msg); /* Note msg = buf and free() above. */ + if (strsiz + msgsiz < BUFSIZ) /* Do not move this after #endif. */ + strcat(str, msg); +#endif + + return str; +} + +char *strerrorcpy(char *str, int err) { + int msgsiz; + char *msg; + +#ifdef USE_THREADS + char *buf = malloc(BUFSIZ); + + if (buf == 0) + return 0; + if (strerror_r(err, buf, sizeof(buf)) == 0) + msg = buf; + else + msg = strerror_r_failed; + msgsiz = strlen(msg); + if (msgsiz < BUFSIZ) + strcpy(str, msg); + free(buf); +#else + if ((msg = strerror(err)) == 0) + msg = strerror_failed; + msgsiz = strlen(msg); /* Note msg = buf and free() above. */ + if (msgsiz < BUFSIZ) /* Do not move this after #endif. */ + strcpy(str, msg); +#endif + + return str; +} + +/* ARGSUSED */ +void *dlopen(char *path, int mode) +{ + register ModulePtr mp; + static void *mainModule; + + /* + * Upon the first call register a terminate handler that will + * close all libraries. Also get a reference to the main module + * for use with loadbind. + */ + if (!mainModule) { + if ((mainModule = findMain()) == NULL) + return NULL; + atexit(terminate); + } + /* + * Scan the list of modules if have the module already loaded. + */ + for (mp = modList; mp; mp = mp->next) + if (strcmp(mp->name, path) == 0) { + mp->refCnt++; + return mp; + } + Newz(1000,mp,1,Module); + if (mp == NULL) { + errvalid++; + strcpy(errbuf, "Newz: "); + strerrorcat(errbuf, errno); + return NULL; + } + + if ((mp->name = savepv(path)) == NULL) { + errvalid++; + strcpy(errbuf, "savepv: "); + strerrorcat(errbuf, errno); + safefree(mp); + return NULL; + } + /* + * load should be declared load(const char *...). Thus we + * cast the path to a normal char *. Ugly. + */ + if ((mp->entry = (void *)load((char *)path, L_NOAUTODEFER, NULL)) == NULL) { + safefree(mp->name); + safefree(mp); + errvalid++; + strcpy(errbuf, "dlopen: "); + strcat(errbuf, path); + strcat(errbuf, ": "); + /* + * If AIX says the file is not executable, the error + * can be further described by querying the loader about + * the last error. + */ + if (errno == ENOEXEC) { + char *tmp[BUFSIZ/sizeof(char *)]; + if (loadquery(L_GETMESSAGES, tmp, sizeof(tmp)) == -1) + strerrorcpy(errbuf, errno); + else { + char **p; + for (p = tmp; *p; p++) + caterr(*p); + } + } else + strerrorcat(errbuf, errno); + return NULL; + } + mp->refCnt = 1; + mp->next = modList; + modList = mp; + if (loadbind(0, mainModule, mp->entry) == -1) { + dlclose(mp); + errvalid++; + strcpy(errbuf, "loadbind: "); + strerrorcat(errbuf, errno); + return NULL; + } + if (readExports(mp) == -1) { + dlclose(mp); + return NULL; + } + return mp; +} + +/* + * Attempt to decipher an AIX loader error message and append it + * to our static error message buffer. + */ +static void caterr(char *s) +{ + register char *p = s; + + while (*p >= '0' && *p <= '9') + p++; + switch(atoi(s)) { + case L_ERROR_TOOMANY: + strcat(errbuf, "to many errors"); + break; + case L_ERROR_NOLIB: + strcat(errbuf, "can't load library"); + strcat(errbuf, p); + break; + case L_ERROR_UNDEF: + strcat(errbuf, "can't find symbol"); + strcat(errbuf, p); + break; + case L_ERROR_RLDBAD: + strcat(errbuf, "bad RLD"); + strcat(errbuf, p); + break; + case L_ERROR_FORMAT: + strcat(errbuf, "bad exec format in"); + strcat(errbuf, p); + break; + case L_ERROR_ERRNO: + strerrorcat(errbuf, atoi(++p)); + break; + default: + strcat(errbuf, s); + break; + } +} + +void *dlsym(void *handle, const char *symbol) +{ + register ModulePtr mp = (ModulePtr)handle; + register ExportPtr ep; + register int i; + + /* + * Could speed up search, but I assume that one assigns + * the result to function pointers anyways. + */ + for (ep = mp->exports, i = mp->nExports; i; i--, ep++) + if (strcmp(ep->name, symbol) == 0) + return ep->addr; + errvalid++; + strcpy(errbuf, "dlsym: undefined symbol "); + strcat(errbuf, symbol); + return NULL; +} + +char *dlerror(void) +{ + if (errvalid) { + errvalid = 0; + return errbuf; + } + return NULL; +} + +int dlclose(void *handle) +{ + register ModulePtr mp = (ModulePtr)handle; + int result; + register ModulePtr mp1; + + if (--mp->refCnt > 0) + return 0; + result = unload(mp->entry); + if (result == -1) { + errvalid++; + strerrorcpy(errbuf, errno); + } + if (mp->exports) { + register ExportPtr ep; + register int i; + for (ep = mp->exports, i = mp->nExports; i; i--, ep++) + if (ep->name) + safefree(ep->name); + safefree(mp->exports); + } + if (mp == modList) + modList = mp->next; + else { + for (mp1 = modList; mp1; mp1 = mp1->next) + if (mp1->next == mp) { + mp1->next = mp->next; + break; + } + } + safefree(mp->name); + safefree(mp); + return result; +} + +static void terminate(void) +{ + while (modList) + dlclose(modList); +} + +/* Added by Wayne Scott + * This is needed because the ldopen system call calls + * calloc to allocated a block of date. The ldclose call calls free. + * Without this we get this system calloc and perl's free, resulting + * in a "Bad free" message. This way we always use perl's malloc. + */ +void *calloc(size_t ne, size_t sz) +{ + void *out; + + out = (void *) safemalloc(ne*sz); + memzero(out, ne*sz); + return(out); +} + +/* + * Build the export table from the XCOFF .loader section. + */ +static int readExports(ModulePtr mp) +{ + LDFILE *ldp = NULL; + SCNHDR sh; + LDHDR *lhp; + char *ldbuf; + LDSYM *ls; + int i; + ExportPtr ep; + + if ((ldp = ldopen(mp->name, ldp)) == NULL) { + struct ld_info *lp; + char *buf; + int size = 4*1024; + if (errno != ENOENT) { + errvalid++; + strcpy(errbuf, "readExports: "); + strerrorcat(errbuf, errno); + return -1; + } + /* + * The module might be loaded due to the LIBPATH + * environment variable. Search for the loaded + * module using L_GETINFO. + */ + if ((buf = safemalloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strerrorcat(errbuf, errno); + return -1; + } + while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { + safefree(buf); + size += 4*1024; + if ((buf = safemalloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strerrorcat(errbuf, errno); + return -1; + } + } + if (i == -1) { + errvalid++; + strcpy(errbuf, "readExports: "); + strerrorcat(errbuf, errno); + safefree(buf); + return -1; + } + /* + * Traverse the list of loaded modules. The entry point + * returned by load() does actually point to the data + * segment origin. + */ + lp = (struct ld_info *)buf; + while (lp) { + if (lp->ldinfo_dataorg == mp->entry) { + ldp = ldopen(lp->ldinfo_filename, ldp); + break; + } + if (lp->ldinfo_next == 0) + lp = NULL; + else + lp = (struct ld_info *)((char *)lp + lp->ldinfo_next); + } + safefree(buf); + if (!ldp) { + errvalid++; + strcpy(errbuf, "readExports: "); + strerrorcat(errbuf, errno); + return -1; + } + } + if (TYPE(ldp) != U802TOCMAGIC) { + errvalid++; + strcpy(errbuf, "readExports: bad magic"); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + if (ldnshread(ldp, _LOADER, &sh) != SUCCESS) { + errvalid++; + strcpy(errbuf, "readExports: cannot read loader section header"); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + /* + * We read the complete loader section in one chunk, this makes + * finding long symbol names residing in the string table easier. + */ + if ((ldbuf = (char *)safemalloc(sh.s_size)) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strerrorcat(errbuf, errno); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + if (FSEEK(ldp, sh.s_scnptr, BEGINNING) != OKFSEEK) { + errvalid++; + strcpy(errbuf, "readExports: cannot seek to loader section"); + safefree(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } +/* This first case is a hack, since it assumes that the 3rd parameter to + FREAD is 1. See the redefinition of FREAD above to see how this works. */ +#ifdef USE_PERLIO + if (FREAD(ldbuf, sh.s_size, 1, ldp) != sh.s_size) { +#else + if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) { +#endif + errvalid++; + strcpy(errbuf, "readExports: cannot read loader section"); + safefree(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + lhp = (LDHDR *)ldbuf; + ls = (LDSYM *)(ldbuf+LDHDRSZ); + /* + * Count the number of exports to include in our export table. + */ + for (i = lhp->l_nsyms; i; i--, ls++) { + if (!LDR_EXPORT(*ls)) + continue; + mp->nExports++; + } + Newz(1001, mp->exports, mp->nExports, Export); + if (mp->exports == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strerrorcat(errbuf, errno); + safefree(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + /* + * Fill in the export table. All entries are relative to + * the entry point we got from load. + */ + ep = mp->exports; + ls = (LDSYM *)(ldbuf+LDHDRSZ); + for (i = lhp->l_nsyms; i; i--, ls++) { + char *symname; + if (!LDR_EXPORT(*ls)) + continue; + if (ls->l_zeroes == 0) + symname = ls->l_offset+lhp->l_stoff+ldbuf; + else + symname = ls->l_name; + ep->name = savepv(symname); + ep->addr = (void *)((unsigned long)mp->entry + ls->l_value); + ep++; + } + safefree(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return 0; +} + +/* + * Find the main modules entry point. This is used as export pointer + * for loadbind() to be able to resolve references to the main part. + */ +static void * findMain(void) +{ + struct ld_info *lp; + char *buf; + int size = 4*1024; + int i; + void *ret; + + if ((buf = safemalloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "findMain: "); + strerrorcat(errbuf, errno); + return NULL; + } + while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { + safefree(buf); + size += 4*1024; + if ((buf = safemalloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "findMain: "); + strerrorcat(errbuf, errno); + return NULL; + } + } + if (i == -1) { + errvalid++; + strcpy(errbuf, "findMain: "); + strerrorcat(errbuf, errno); + safefree(buf); + return NULL; + } + /* + * The first entry is the main module. The entry point + * returned by load() does actually point to the data + * segment origin. + */ + lp = (struct ld_info *)buf; + ret = lp->ldinfo_dataorg; + safefree(buf); + return ret; +} + +/* dl_dlopen.xs + * + * Platform: SunOS/Solaris, possibly others which use dlopen. + * Author: Paul Marquess (pmarquess@bfsec.bt.co.uk) + * Created: 10th July 1994 + * + * Modified: + * 15th July 1994 - Added code to explicitly save any error messages. + * 3rd August 1994 - Upgraded to v3 spec. + * 9th August 1994 - Changed to use IV + * 10th August 1994 - Tim Bunce: Added RTLD_LAZY, switchable debugging, + * basic FreeBSD support, removed ClearError + * + */ + +/* Porting notes: + + see dl_dlopen.xs + +*/ + +#include "dlutils.c" /* SaveError() etc */ + + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + +void * +dl_load_file(filename, flags=0) + char * filename + int flags + CODE: + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + if (flags & 0x01) + warn("Can't make loaded symbols global on this platform while loading %s",filename); + RETVAL = dlopen(filename, 1) ; + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + RETVAL = dlsym(libhandle, symbolname); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs b/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs new file mode 100644 index 0000000..2b75637 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs @@ -0,0 +1,153 @@ +/* dl_cygwin32.xs + * + * Platform: Win32 (Windows NT/Windows 95) + * Author: Wei-Yuen Tan (wyt@hip.com) + * Created: A warm day in June, 1995 + * + * Modified: + * August 23rd 1995 - rewritten after losing everything when I + * wiped off my NT partition (eek!) + */ +/* Modified from the original dl_win32.xs to work with cygwin32 + -John Cerney 3/26/97 +*/ +/* Porting notes: + +I merely took Paul's dl_dlopen.xs, took out extraneous stuff and +replaced the appropriate SunOS calls with the corresponding Win32 +calls. + +*/ + +#define WIN32_LEAN_AND_MEAN +// Defines from windows needed for this function only. Can't include full +// Cygwin32 windows headers because of problems with CONTEXT redefinition +// Removed logic to tell not dynamically load static modules. It is assumed that all +// modules are dynamically built. This should be similar to the behavoir on sunOS. +// Leaving in the logic would have required changes to the standard perlmain.c code +// +// // Includes call a dll function to initialize it's impure_ptr. +#include +void (*impure_setupptr)(struct _reent *); // pointer to the impure_setup routine + +//#include +#define LOAD_WITH_ALTERED_SEARCH_PATH (8) +typedef void *HANDLE; +typedef HANDLE HINSTANCE; +#define STDCALL __attribute__ ((stdcall)) +typedef int STDCALL (*FARPROC)(); + +HINSTANCE +STDCALL +LoadLibraryExA( + char* lpLibFileName, + HANDLE hFile, + unsigned int dwFlags + ); +unsigned int +STDCALL +GetLastError( + void + ); +FARPROC +STDCALL +GetProcAddress( + HINSTANCE hModule, + char* lpProcName + ); + +#include + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "dlutils.c" /* SaveError() etc */ + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); +} + + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + +void * +dl_load_file(filename,flags=0) + char * filename + int flags + PREINIT: + CODE: + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + + RETVAL = (void*) LoadLibraryExA(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH ) ; + + DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL){ + SaveError("%d",GetLastError()) ; + } + else{ + // setup the dll's impure_ptr: + impure_setupptr = GetProcAddress(RETVAL, "impure_setup"); + if( impure_setupptr == NULL){ + printf( + "Cygwin32 dynaloader error: could not load impure_setup symbol\n"); + RETVAL = NULL; + } + else{ + // setup the DLLs impure_ptr: + (*impure_setupptr)(_impure_ptr); + sv_setiv( ST(0), (IV)RETVAL); + } + } + + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname); + DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%d",GetLastError()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_dld.xs b/contrib/perl5/ext/DynaLoader/dl_dld.xs new file mode 100644 index 0000000..2443ab0 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_dld.xs @@ -0,0 +1,175 @@ +/* + * Written 3/1/94, Robert Sanders + * + * based upon the file "dl.c", which is + * Copyright (c) 1994, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Date: 1994/03/07 00:21:43 $ + * $Source: /home/rsanders/src/perl5alpha6/RCS/dld_dl.c,v $ + * $Revision: 1.4 $ + * $State: Exp $ + * + * $Log: dld_dl.c,v $ + * Removed implicit link against libc. 1994/09/14 William Setzer. + * + * Integrated other DynaLoader changes. 1994/06/08 Tim Bunce. + * + * rewrote dl_load_file, misc updates. 1994/09/03 William Setzer. + * + * Revision 1.4 1994/03/07 00:21:43 rsanders + * added min symbol count for load_libs and switched order so system libs + * are loaded after app-specified libs. + * + * Revision 1.3 1994/03/05 01:17:26 rsanders + * added path searching. + * + * Revision 1.2 1994/03/05 00:52:39 rsanders + * added package-specified libraries. + * + * Revision 1.1 1994/03/05 00:33:40 rsanders + * Initial revision + * + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include /* GNU DLD header file */ +#include + +#include "dlutils.c" /* for SaveError() etc */ + +static AV *dl_resolve_using = Nullav; +static AV *dl_require_symbols = Nullav; + +static void +dl_private_init() +{ + int dlderr; + dl_generic_private_init(); + dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); + dl_require_symbols = perl_get_av("DynaLoader::dl_require_symbols", 0x4); +#ifdef __linux__ + dlderr = dld_init("/proc/self/exe"); + if (dlderr) { +#endif + dlderr = dld_init(dld_find_executable(PL_origargv[0])); + if (dlderr) { + char *msg = dld_strerror(dlderr); + SaveError("dld_init(%s) failed: %s", PL_origargv[0], msg); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "%s", LastError)); + } +#ifdef __linux__ + } +#endif +} + + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + +char * +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: + int dlderr,x,max; + GV *gv; + CODE: + RETVAL = filename; + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + if (flags & 0x01) + croak("Can't make loaded symbols global on this platform while loading %s",filename); + max = AvFILL(dl_require_symbols); + for (x = 0; x <= max; x++) { + char *sym = SvPVX(*av_fetch(dl_require_symbols, x, 0)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_create_ref(%s)\n", sym)); + if (dlderr = dld_create_reference(sym)) { + SaveError("dld_create_reference(%s): %s", sym, + dld_strerror(dlderr)); + goto haverror; + } + } + + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_link(%s)\n", filename)); + if (dlderr = dld_link(filename)) { + SaveError("dld_link(%s): %s", filename, dld_strerror(dlderr)); + goto haverror; + } + + max = AvFILL(dl_resolve_using); + for (x = 0; x <= max; x++) { + char *sym = SvPVX(*av_fetch(dl_resolve_using, x, 0)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_link(%s)\n", sym)); + if (dlderr = dld_link(sym)) { + SaveError("dld_link(%s): %s", sym, dld_strerror(dlderr)); + goto haverror; + } + } + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "libref=%s\n", RETVAL)); +haverror: + ST(0) = sv_newmortal() ; + if (dlderr == 0) + sv_setiv(ST(0), (IV)RETVAL); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + RETVAL = (void *)dld_get_func(symbolname); + /* if RETVAL==NULL we should try looking for a non-function symbol */ + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("dl_find_symbol: Unable to find '%s' symbol", symbolname) ; + else + sv_setiv(ST(0), (IV)RETVAL); + + +void +dl_undef_symbols() + PPCODE: + if (dld_undefined_sym_count) { + int x; + char **undef_syms = dld_list_undefined_sym(); + EXTEND(SP, dld_undefined_sym_count); + for (x=0; x < dld_undefined_sym_count; x++) + PUSHs(sv_2mortal(newSVpv(undef_syms[x]+1, 0))); + free(undef_syms); + } + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_dlopen.xs b/contrib/perl5/ext/DynaLoader/dl_dlopen.xs new file mode 100644 index 0000000..2459205 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_dlopen.xs @@ -0,0 +1,219 @@ +/* dl_dlopen.xs + * + * Platform: SunOS/Solaris, possibly others which use dlopen. + * Author: Paul Marquess (pmarquess@bfsec.bt.co.uk) + * Created: 10th July 1994 + * + * Modified: + * 15th July 1994 - Added code to explicitly save any error messages. + * 3rd August 1994 - Upgraded to v3 spec. + * 9th August 1994 - Changed to use IV + * 10th August 1994 - Tim Bunce: Added RTLD_LAZY, switchable debugging, + * basic FreeBSD support, removed ClearError + * + */ + +/* Porting notes: + + + Definition of Sunos dynamic Linking functions + ============================================= + In order to make this implementation easier to understand here is a + quick definition of the SunOS Dynamic Linking functions which are + used here. + + dlopen + ------ + void * + dlopen(path, mode) + char * path; + int mode; + + This function takes the name of a dynamic object file and returns + a descriptor which can be used by dlsym later. It returns NULL on + error. + + The mode parameter must be set to 1 for Solaris 1 and to + RTLD_LAZY (==2) on Solaris 2. + + + dlsym + ------ + void * + dlsym(handle, symbol) + void * handle; + char * symbol; + + Takes the handle returned from dlopen and the name of a symbol to + get the address of. If the symbol was found a pointer is + returned. It returns NULL on error. If DL_PREPEND_UNDERSCORE is + defined an underscore will be added to the start of symbol. This + is required on some platforms (freebsd). + + dlerror + ------ + char * dlerror() + + Returns a null-terminated string which describes the last error + that occurred with either dlopen or dlsym. After each call to + dlerror the error message will be reset to a null pointer. The + SaveError function is used to save the error as soo as it happens. + + + Return Types + ============ + In this implementation the two functions, dl_load_file & + dl_find_symbol, return void *. This is because the underlying SunOS + dynamic linker calls also return void *. This is not necessarily + the case for all architectures. For example, some implementation + will want to return a char * for dl_load_file. + + If void * is not appropriate for your architecture, you will have to + change the void * to whatever you require. If you are not certain of + how Perl handles C data types, I suggest you start by consulting + Dean Roerich's Perl 5 API document. Also, have a look in the typemap + file (in the ext directory) for a fairly comprehensive list of types + that are already supported. If you are completely stuck, I suggest you + post a message to perl5-porters, comp.lang.perl.misc or if you are really + desperate to me. + + Remember when you are making any changes that the return value from + dl_load_file is used as a parameter in the dl_find_symbol + function. Also the return value from find_symbol is used as a parameter + to install_xsub. + + + Dealing with Error Messages + ============================ + In order to make the handling of dynamic linking errors as generic as + possible you should store any error messages associated with your + implementation with the StoreError function. + + In the case of SunOS the function dlerror returns the error message + associated with the last dynamic link error. As the SunOS dynamic + linker functions dlopen & dlsym both return NULL on error every call + to a SunOS dynamic link routine is coded like this + + RETVAL = dlopen(filename, 1) ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + + Note that SaveError() takes a printf format string. Use a "%s" as + the first parameter if the error may contain and % characters. + +*/ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifdef I_DLFCN +#include /* the dynamic linker include file for Sunos/Solaris */ +#else +#include +#include +#endif + +#ifndef RTLD_LAZY +# define RTLD_LAZY 1 /* Solaris 1 */ +#endif + +#ifndef HAS_DLERROR +# ifdef __NetBSD__ +# define dlerror() strerror(errno) +# else +# define dlerror() "Unknown error - dlerror() not implemented" +# endif +#endif + + +#include "dlutils.c" /* SaveError() etc */ + + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + +void * +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: + int mode = RTLD_LAZY; + CODE: +#ifdef RTLD_NOW + if (dl_nonlazy) + mode = RTLD_NOW; +#endif + if (flags & 0x01) +#ifdef RTLD_GLOBAL + mode |= RTLD_GLOBAL; +#else + warn("Can't make loaded symbols global on this platform while loading %s",filename); +#endif + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + RETVAL = dlopen(filename, mode) ; + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%lx\n", (unsigned long) RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: +#ifdef DLSYM_NEEDS_UNDERSCORE + symbolname = form("_%s", symbolname); +#endif + DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + "dl_find_symbol(handle=%lx, symbol=%s)\n", + (unsigned long) libhandle, symbolname)); + RETVAL = dlsym(libhandle, symbolname); + DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + " symbolref = %lx\n", (unsigned long) RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%lx)\n", + perl_name, (unsigned long) symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)_((CV *)))symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_hpux.xs b/contrib/perl5/ext/DynaLoader/dl_hpux.xs new file mode 100644 index 0000000..a82e0ea --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_hpux.xs @@ -0,0 +1,157 @@ +/* + * Author: Jeff Okamoto (okamoto@corp.hp.com) + * Version: 2.1, 1995/1/25 + */ + +/* o Added BIND_VERBOSE to dl_nonlazy condition to add names of missing + * symbols to stderr message on fatal error. + * + * o Added BIND_NONFATAL comment to default condition. + * + * Chuck Phillips (cdp@fc.hp.com) + * Version: 2.2, 1997/5/4 */ + +#ifdef __hp9000s300 +#define magic hpux_magic +#define MAGIC HPUX_MAGIC +#endif + +#include +#ifdef __hp9000s300 +#undef magic +#undef MAGIC +#endif + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + + +#include "dlutils.c" /* for SaveError() etc */ + +static AV *dl_resolve_using = Nullav; + + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); + dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + +void * +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: + shl_t obj = NULL; + int i, max, bind_type; + CODE: + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + if (flags & 0x01) + warn("Can't make loaded symbols global on this platform while loading %s",filename); + if (dl_nonlazy) { + bind_type = BIND_IMMEDIATE|BIND_VERBOSE; + } else { + bind_type = BIND_DEFERRED; + /* For certain libraries, like DCE, deferred binding often causes run + * time problems. Adding BIND_NONFATAL to BIND_IMMEDIATE still allows + * unresolved references in situations like this. */ + /* bind_type = BIND_IMMEDIATE|BIND_NONFATAL; */ + } + /* BIND_NOSTART removed from bind_type because it causes the shared library's */ + /* initialisers not to be run. This causes problems with all of the static objects */ + /* in the library. */ +#ifdef DEBUGGING + if (dl_debug) + bind_type |= BIND_VERBOSE; +#endif /* DEBUGGING */ + + max = AvFILL(dl_resolve_using); + for (i = 0; i <= max; i++) { + char *sym = SvPVX(*av_fetch(dl_resolve_using, i, 0)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s) (dependent)\n", sym)); + obj = shl_load(sym, bind_type, 0L); + if (obj == NULL) { + goto end; + } + } + + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s): ", filename)); + obj = shl_load(filename, bind_type, 0L); + + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", obj)); +end: + ST(0) = sv_newmortal() ; + if (obj == NULL) + SaveError("%s",Strerror(errno)); + else + sv_setiv( ST(0), (IV)obj); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + shl_t obj = (shl_t) libhandle; + void *symaddr = NULL; + int status; +#ifdef __hp9000s300 + symbolname = form("_%s", symbolname); +#endif + DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + "dl_find_symbol(handle=%lx, symbol=%s)\n", + (unsigned long) libhandle, symbolname)); + + ST(0) = sv_newmortal() ; + errno = 0; + + status = shl_findsym(&obj, symbolname, TYPE_PROCEDURE, &symaddr); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref(PROCEDURE) = %x\n", symaddr)); + + if (status == -1 && errno == 0) { /* try TYPE_DATA instead */ + status = shl_findsym(&obj, symbolname, TYPE_DATA, &symaddr); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref(DATA) = %x\n", symaddr)); + } + + if (status == -1) { + SaveError("%s",(errno) ? Strerror(errno) : "Symbol not found") ; + } else { + sv_setiv( ST(0), (IV)symaddr); + } + + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_mpeix.xs b/contrib/perl5/ext/DynaLoader/dl_mpeix.xs new file mode 100644 index 0000000..808c3b0 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_mpeix.xs @@ -0,0 +1,128 @@ +/* + * Author: Mark Klein (mklein@dis.com) + * Version: 2.1, 1996/07/25 + * Version: 2.2, 1997/09/25 Mark Bixby (markb@cccd.edu) + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifdef __GNUC__ +extern void HPGETPROCPLABEL( int parms, + char * procname, + int * plabel, + int * status, + char * firstfile, + int casesensitive, + int symboltype, + int * datasize, + int position, + int searchpath, + int binding); +#else +#pragma intrinsic HPGETPROCPLABEL +#endif +#include "dlutils.c" /* for SaveError() etc */ + +typedef struct { + char filename[PATH_MAX + 3]; + } t_mpe_dld, *p_mpe_dld; + +static AV *dl_resolve_using = Nullav; + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); + dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + +void * +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: + char buf[PATH_MAX + 3]; + p_mpe_dld obj = NULL; + int i; + CODE: + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename, +flags)); + if (flags & 0x01) + warn("Can't make loaded symbols global on this platform while loading %s +",filename); + obj = (p_mpe_dld) safemalloc(sizeof(t_mpe_dld)); + memzero(obj, sizeof(t_mpe_dld)); + if (filename[0] == '.') + { + getcwd(buf,sizeof(buf)); + sprintf(obj->filename,"$%s/%s$",buf,filename); + } + else + sprintf(obj->filename,"$%s$",filename); + + DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," libref=%x\n", obj)); + + ST(0) = sv_newmortal() ; + if (obj == NULL) + SaveError("%s",Strerror(errno)); + else + sv_setiv( ST(0), (IV)obj); + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + int datalen; + p_mpe_dld obj = (p_mpe_dld) libhandle; + char symname[PATH_MAX + 3]; + void * symaddr = NULL; + int status; + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + ST(0) = sv_newmortal() ; + errno = 0; + + sprintf(symname, "$%s$", symbolname); + HPGETPROCPLABEL(8, symname, &symaddr, &status, obj->filename, 1, + 0, &datalen, 1, 0, 0); + + DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," symbolref(PROCEDURE) = %x\n", symaddr)); + + if (status != 0) { + SaveError("%s",(errno) ? Strerror(errno) : "Symbol not found") ; + } else { + sv_setiv( ST(0), (IV)symaddr); + } + +void +dl_undef_symbols() + PPCODE: + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_next.xs b/contrib/perl5/ext/DynaLoader/dl_next.xs new file mode 100644 index 0000000..2b547f0 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_next.xs @@ -0,0 +1,303 @@ +/* dl_next.xs + * + * Platform: NeXT NS 3.2 + * Author: Anno Siegel (siegel@zrz.TU-Berlin.DE) + * Based on: dl_dlopen.xs by Paul Marquess + * Created: Aug 15th, 1994 + * + */ + +/* + And Gandalf said: 'Many folk like to know beforehand what is to + be set on the table; but those who have laboured to prepare the + feast like to keep their secret; for wonder makes the words of + praise louder.' +*/ + +/* Porting notes: + +dl_next.xs is itself a port from dl_dlopen.xs by Paul Marquess. It +should not be used as a base for further ports though it may be used +as an example for how dl_dlopen.xs can be ported to other platforms. + +The method used here is just to supply the sun style dlopen etc. +functions in terms of NeXTs rld_*. The xs code proper is unchanged +from Paul's original. + +The port could use some streamlining. For one, error handling could +be simplified. + +Anno Siegel + +*/ + +#if NS_TARGET_MAJOR >= 4 +#else +/* include these before perl headers */ +#include +#include +#endif + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define DL_LOADONCEONLY + +#include "dlutils.c" /* SaveError() etc */ + + +static char * dl_last_error = (char *) 0; +static AV *dl_resolve_using = Nullav; + +static char *dlerror() +{ + return dl_last_error; +} + +int dlclose(handle) /* stub only */ +void *handle; +{ + return 0; +} + +#if NS_TARGET_MAJOR >= 4 +#import + +enum dyldErrorSource +{ + OFImage, +}; + +static void TranslateError + (const char *path, enum dyldErrorSource type, int number) +{ + char *error; + unsigned int index; + static char *OFIErrorStrings[] = + { + "%s(%d): Object Image Load Failure\n", + "%s(%d): Object Image Load Success\n", + "%s(%d): Not an recognisable object file\n", + "%s(%d): No valid architecture\n", + "%s(%d): Object image has an invalid format\n", + "%s(%d): Invalid access (permissions?)\n", + "%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n", + }; +#define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0])) + + switch (type) + { + case OFImage: + index = number; + if (index > NUM_OFI_ERRORS - 1) + index = NUM_OFI_ERRORS - 1; + error = form(OFIErrorStrings[index], path, number); + break; + + default: + error = form("%s(%d): Totally unknown error type %d\n", + path, number, type); + break; + } + Safefree(dl_last_error); + dl_last_error = savepv(error); +} + +static char *dlopen(char *path, int mode /* mode is ignored */) +{ + int dyld_result; + NSObjectFileImage ofile; + NSModule handle = NULL; + + dyld_result = NSCreateObjectFileImageFromFile(path, &ofile); + if (dyld_result != NSObjectFileImageSuccess) + TranslateError(path, OFImage, dyld_result); + else + { + // NSLinkModule will cause the run to abort on any link error's + // not very friendly but the error recovery functionality is limited. + handle = NSLinkModule(ofile, path, TRUE); + } + + return handle; +} + +void * +dlsym(handle, symbol) +void *handle; +char *symbol; +{ + void *addr; + + if (NSIsSymbolNameDefined(symbol)) + addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol)); + else + addr = NULL; + + return addr; +} + +#else /* NS_TARGET_MAJOR <= 3 */ + +static NXStream *OpenError(void) +{ + return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY); +} + +static void TransferError(NXStream *s) +{ + char *buffer; + int len, maxlen; + + if ( dl_last_error ) { + Safefree(dl_last_error); + } + NXGetMemoryBuffer(s, &buffer, &len, &maxlen); + New(1097, dl_last_error, len, char); + strcpy(dl_last_error, buffer); +} + +static void CloseError(NXStream *s) +{ + if ( s ) { + NXCloseMemory( s, NX_FREEBUFFER); + } +} + +static char *dlopen(char *path, int mode /* mode is ignored */) +{ + int rld_success; + NXStream *nxerr; + I32 i, psize; + char *result; + char **p; + + /* Do not load what is already loaded into this process */ + if (hv_fetch(dl_loaded_files, path, strlen(path), 0)) + return path; + + nxerr = OpenError(); + psize = AvFILL(dl_resolve_using) + 3; + p = (char **) safemalloc(psize * sizeof(char*)); + p[0] = path; + for(i=1; i= 4 */ + + +/* ----- code from dl_dlopen.xs below here ----- */ + + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); + dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + + +void * +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: + int mode = 1; + CODE: + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + if (flags & 0x01) + warn("Can't make loaded symbols global on this platform while loading %s",filename); + RETVAL = dlopen(filename, mode) ; + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: +#if NS_TARGET_MAJOR >= 4 + symbolname = form("_%s", symbolname); +#endif + DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + "dl_find_symbol(handle=%lx, symbol=%s)\n", + (unsigned long) libhandle, symbolname)); + RETVAL = dlsym(libhandle, symbolname); + DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + " symbolref = %lx\n", (unsigned long) RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_none.xs b/contrib/perl5/ext/DynaLoader/dl_none.xs new file mode 100644 index 0000000..5a193e4 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_none.xs @@ -0,0 +1,19 @@ +/* dl_none.xs + * + * Stubs for platforms that do not support dynamic linking + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +MODULE = DynaLoader PACKAGE = DynaLoader + +char * +dl_error() + CODE: + RETVAL = "Not implemented"; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_vms.xs b/contrib/perl5/ext/DynaLoader/dl_vms.xs new file mode 100644 index 0000000..974fd58 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_vms.xs @@ -0,0 +1,356 @@ +/* dl_vms.xs + * + * Platform: OpenVMS, VAX or AXP + * Author: Charles Bailey bailey@genetics.upenn.edu + * Revised: 12-Dec-1994 + * + * Implementation Note + * This section is added as an aid to users and DynaLoader developers, in + * order to clarify the process of dynamic linking under VMS. + * dl_vms.xs uses the supported VMS dynamic linking call, which allows + * a running program to map an arbitrary file of executable code and call + * routines within that file. This is done via the VMS RTL routine + * lib$find_image_symbol, whose calling sequence is as follows: + * status = lib$find_image_symbol(imgname,symname,symval,defspec); + * where + * status = a standard VMS status value (unsigned long int) + * imgname = a fixed-length string descriptor, passed by + * reference, containing the NAME ONLY of the image + * file to be mapped. An attempt will be made to + * translate this string as a logical name, so it may + * not contain any characters which are not allowed in + * logical names. If no translation is found, imgname + * is used directly as the name of the image file. + * symname = a fixed-length string descriptor, passed by + * reference, containing the name of the routine + * to be located. + * symval = an unsigned long int, passed by reference, into + * which is written the entry point address of the + * routine whose name is specified in symname. + * defspec = a fixed-length string descriptor, passed by + * reference, containing a default file specification + * whichis used to fill in any missing parts of the + * image file specification after the imgname argument + * is processed. + * In order to accommodate the handling of the imgname argument, the routine + * dl_expandspec() is provided for use by perl code (e.g. dl_findfile) + * which wants to see what image file lib$find_image_symbol would use if + * it were passed a given file specification. The file specification passed + * to dl_expandspec() and dl_load_file() can be partial or complete, and can + * use VMS or Unix syntax; these routines perform the necessary conversions. + * In general, writers of perl extensions need only conform to the + * procedures set out in the DynaLoader documentation, and let the details + * be taken care of by the routines here and in DynaLoader.pm. If anyone + * comes across any incompatibilities, please let me know. Thanks. + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "dlutils.c" /* dl_debug, LastError; SaveError not used */ + +static AV *dl_require_symbols = Nullav; + +/* N.B.: + * dl_debug and LastError are static vars; you'll need to deal + * with them appropriately if you need context independence + */ + +#include +#include +#include +#include +#include +#include + +typedef unsigned long int vmssts; + +struct libref { + struct dsc$descriptor_s name; + struct dsc$descriptor_s defspec; +}; + +/* Static data for dl_expand_filespec() - This is static to save + * initialization on each call; if you need context-independence, + * just make these auto variables in dl_expandspec() and dl_load_file() + */ +static char dlesa[NAM$C_MAXRSS], dlrsa[NAM$C_MAXRSS]; +static struct FAB dlfab; +static struct NAM dlnam; + +/* $PutMsg action routine - records error message in LastError */ +static vmssts +copy_errmsg(msg,unused) + struct dsc$descriptor_s * msg; + vmssts unused; +{ + if (*(msg->dsc$a_pointer) == '%') { /* first line */ + if (LastError) + strncpy((LastError = saferealloc(LastError,msg->dsc$w_length+1)), + msg->dsc$a_pointer, msg->dsc$w_length); + else + strncpy((LastError = safemalloc(msg->dsc$w_length+1)), + msg->dsc$a_pointer, msg->dsc$w_length); + LastError[msg->dsc$w_length] = '\0'; + } + else { /* continuation line */ + int errlen = strlen(LastError); + LastError = saferealloc(LastError, errlen + msg->dsc$w_length + 2); + LastError[errlen] = '\n'; LastError[errlen+1] = '\0'; + strncat(LastError, msg->dsc$a_pointer, msg->dsc$w_length); + LastError[errlen+msg->dsc$w_length+1] = '\0'; + } + return 0; +} + +/* Use $PutMsg to retrieve error message for failure status code */ +static void +dl_set_error(sts,stv) + vmssts sts; + vmssts stv; +{ + vmssts vec[3]; + + vec[0] = stv ? 2 : 1; + vec[1] = sts; vec[2] = stv; + _ckvmssts(sys$putmsg(vec,copy_errmsg,0,0)); +} + +static unsigned int +findsym_handler(void *sig, void *mech) +{ + unsigned long int myvec[8],args, *usig = (unsigned long int *) sig; + /* Be paranoid and assume signal vector passed in might be readonly */ + myvec[0] = args = usig[0] > 10 ? 9 : usig[0] - 1; + while (--args) myvec[args] = usig[args]; + _ckvmssts(sys$putmsg(myvec,copy_errmsg,0,0)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "findsym_handler: received\n\t%s\n",LastError)); + return SS$_CONTINUE; +} + +/* wrapper for lib$find_image_symbol, so signalled errors can be saved + * for dl_error and then returned */ +static unsigned long int +my_find_image_symbol(struct dsc$descriptor_s *imgname, + struct dsc$descriptor_s *symname, + void (**entry)(), + struct dsc$descriptor_s *defspec) +{ + unsigned long int retsts; + VAXC$ESTABLISH(findsym_handler); + retsts = lib$find_image_symbol(imgname,symname,entry,defspec); + return retsts; +} + + +static void +dl_private_init() +{ + dl_generic_private_init(); + dl_require_symbols = perl_get_av("DynaLoader::dl_require_symbols", 0x4); + /* Set up the static control blocks for dl_expand_filespec() */ + dlfab = cc$rms_fab; + dlnam = cc$rms_nam; + dlfab.fab$l_nam = &dlnam; + dlnam.nam$l_esa = dlesa; + dlnam.nam$b_ess = sizeof dlesa; + dlnam.nam$l_rsa = dlrsa; + dlnam.nam$b_rss = sizeof dlrsa; +} +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + +void +dl_expandspec(filespec) + char * filespec + CODE: + char vmsspec[NAM$C_MAXRSS], defspec[NAM$C_MAXRSS]; + size_t deflen; + vmssts sts; + + tovmsspec(filespec,vmsspec); + dlfab.fab$l_fna = vmsspec; + dlfab.fab$b_fns = strlen(vmsspec); + dlfab.fab$l_dna = 0; + dlfab.fab$b_dns = 0; + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_expand_filespec(%s):\n",vmsspec)); + /* On the first pass, just parse the specification string */ + dlnam.nam$b_nop = NAM$M_SYNCHK; + sts = sys$parse(&dlfab); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tSYNCHK sys$parse = %d\n",sts)); + if (!(sts & 1)) { + dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); + ST(0) = &PL_sv_undef; + } + else { + /* Now set up a default spec - everything but the name */ + deflen = dlnam.nam$l_name - dlesa; + memcpy(defspec,dlesa,deflen); + memcpy(defspec+deflen,dlnam.nam$l_type, + dlnam.nam$b_type + dlnam.nam$b_ver); + deflen += dlnam.nam$b_type + dlnam.nam$b_ver; + memcpy(vmsspec,dlnam.nam$l_name,dlnam.nam$b_name); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsplit filespec: name = %.*s, default = %.*s\n", + dlnam.nam$b_name,vmsspec,deflen,defspec)); + /* . . . and go back to expand it */ + dlnam.nam$b_nop = 0; + dlfab.fab$l_dna = defspec; + dlfab.fab$b_dns = deflen; + dlfab.fab$b_fns = dlnam.nam$b_name; + sts = sys$parse(&dlfab); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tname/default sys$parse = %d\n",sts)); + if (!(sts & 1)) { + dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); + ST(0) = &PL_sv_undef; + } + else { + /* Now find the actual file */ + sts = sys$search(&dlfab); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsys$search = %d\n",sts)); + if (!(sts & 1)) { + dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); + ST(0) = &PL_sv_undef; + } + else { + ST(0) = sv_2mortal(newSVpv(dlnam.nam$l_rsa,dlnam.nam$b_rsl)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "\tresult = \\%.*s\\\n", + dlnam.nam$b_rsl,dlnam.nam$l_rsa)); + } + } + } + +void +dl_load_file(filespec, flags) + char * filespec + int flags + PREINIT: + char vmsspec[NAM$C_MAXRSS]; + SV *reqSV, **reqSVhndl; + STRLEN deflen; + struct dsc$descriptor_s + specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}, + symdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + struct fscnlst { + unsigned short int len; + unsigned short int code; + char *string; + } namlst[2] = {{0,FSCN$_NAME,0},{0,0,0}}; + struct libref *dlptr; + vmssts sts, failed = 0; + void (*entry)(); + CODE: + + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filespec,flags)); + specdsc.dsc$a_pointer = tovmsspec(filespec,vmsspec); + specdsc.dsc$w_length = strlen(specdsc.dsc$a_pointer); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tVMS-ified filespec is %s\n", + specdsc.dsc$a_pointer)); + New(1399,dlptr,1,struct libref); + dlptr->name.dsc$b_dtype = dlptr->defspec.dsc$b_dtype = DSC$K_DTYPE_T; + dlptr->name.dsc$b_class = dlptr->defspec.dsc$b_class = DSC$K_CLASS_S; + sts = sys$filescan(&specdsc,namlst,0); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsys$filescan: returns %d, name is %.*s\n", + sts,namlst[0].len,namlst[0].string)); + if (!(sts & 1)) { + failed = 1; + dl_set_error(sts,0); + } + else { + dlptr->name.dsc$w_length = namlst[0].len; + dlptr->name.dsc$a_pointer = savepvn(namlst[0].string,namlst[0].len); + dlptr->defspec.dsc$w_length = specdsc.dsc$w_length - namlst[0].len; + New(1097, dlptr->defspec.dsc$a_pointer, dlptr->defspec.dsc$w_length + 1, char); + deflen = namlst[0].string - specdsc.dsc$a_pointer; + memcpy(dlptr->defspec.dsc$a_pointer,specdsc.dsc$a_pointer,deflen); + memcpy(dlptr->defspec.dsc$a_pointer + deflen, + namlst[0].string + namlst[0].len, + dlptr->defspec.dsc$w_length - deflen); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlibref = name: %s, defspec: %.*s\n", + dlptr->name.dsc$a_pointer, + dlptr->defspec.dsc$w_length, + dlptr->defspec.dsc$a_pointer)); + if (!(reqSVhndl = av_fetch(dl_require_symbols,0,FALSE)) || !(reqSV = *reqSVhndl)) { + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\t@dl_require_symbols empty, returning untested libref\n")); + } + else { + symdsc.dsc$w_length = SvCUR(reqSV); + symdsc.dsc$a_pointer = SvPVX(reqSV); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\t$dl_require_symbols[0] = %.*s\n", + symdsc.dsc$w_length, symdsc.dsc$a_pointer)); + sts = my_find_image_symbol(&(dlptr->name),&symdsc, + &entry,&(dlptr->defspec)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlib$find_image_symbol returns %d\n",sts)); + if (!(sts&1)) { + failed = 1; + dl_set_error(sts,0); + } + } + } + + if (failed) { + Safefree(dlptr->name.dsc$a_pointer); + Safefree(dlptr->defspec.dsc$a_pointer); + Safefree(dlptr); + ST(0) = &PL_sv_undef; + } + else { + ST(0) = sv_2mortal(newSViv((IV) dlptr)); + } + + +void +dl_find_symbol(librefptr,symname) + void * librefptr + SV * symname + CODE: + struct libref thislib = *((struct libref *)librefptr); + struct dsc$descriptor_s + symdsc = {SvCUR(symname),DSC$K_DTYPE_T,DSC$K_CLASS_S,SvPVX(symname)}; + void (*entry)(); + vmssts sts; + + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_find_dymbol(%.*s,%.*s):\n", + thislib.name.dsc$w_length, thislib.name.dsc$a_pointer, + symdsc.dsc$w_length,symdsc.dsc$a_pointer)); + sts = my_find_image_symbol(&(thislib.name),&symdsc, + &entry,&(thislib.defspec)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlib$find_image_symbol returns %d\n",sts)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tentry point is %d\n", + (unsigned long int) entry)); + if (!(sts & 1)) { + /* error message already saved by findsym_handler */ + ST(0) = &PL_sv_undef; + } + else ST(0) = sv_2mortal(newSViv((IV) entry)); + + +void +dl_undef_symbols() + PPCODE: + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dlutils.c b/contrib/perl5/ext/DynaLoader/dlutils.c new file mode 100644 index 0000000..bfa1f78 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dlutils.c @@ -0,0 +1,72 @@ +/* dlutils.c - handy functions and definitions for dl_*.xs files + * + * Currently this file is simply #included into dl_*.xs/.c files. + * It should really be split into a dlutils.h and dlutils.c + * + */ + + +/* pointer to allocated memory for last error message */ +static char *LastError = (char*)NULL; + +/* flag for immediate rather than lazy linking (spots unresolved symbol) */ +static int dl_nonlazy = 0; + +#ifdef DL_LOADONCEONLY +static HV *dl_loaded_files = Nullhv; /* only needed on a few systems */ +#endif + + +#ifdef DEBUGGING +static int dl_debug = 0; /* value copied from $DynaLoader::dl_error */ +#define DLDEBUG(level,code) if (dl_debug>=level) { code; } +#else +#define DLDEBUG(level,code) +#endif + + +static void +dl_generic_private_init(CPERLarg) /* called by dl_*.xs dl_private_init() */ +{ + char *perl_dl_nonlazy; +#ifdef DEBUGGING + dl_debug = SvIV( perl_get_sv("DynaLoader::dl_debug", 0x04) ); +#endif + if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL ) + dl_nonlazy = atoi(perl_dl_nonlazy); + if (dl_nonlazy) + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "DynaLoader bind mode is 'non-lazy'\n")); +#ifdef DL_LOADONCEONLY + if (!dl_loaded_files) + dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */ +#endif +} + + +/* SaveError() takes printf style args and saves the result in LastError */ +static void +SaveError(CPERLarg_ char* pat, ...) +{ + va_list args; + char *message; + int len; + + /* This code is based on croak/warn, see mess() in util.c */ + + va_start(args, pat); + message = mess(pat, &args); + va_end(args); + + len = strlen(message) + 1 ; /* include terminating null char */ + + /* Allocate some memory for the error message */ + if (LastError) + LastError = (char*)saferealloc(LastError, len) ; + else + LastError = (char *) safemalloc(len) ; + + /* Copy message into LastError (including terminating null char) */ + strncpy(LastError, message, len) ; + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "DynaLoader: stored error msg '%s'\n",LastError)); +} + diff --git a/contrib/perl5/ext/Errno/ChangeLog b/contrib/perl5/ext/Errno/ChangeLog new file mode 100644 index 0000000..2bfa003 --- /dev/null +++ b/contrib/perl5/ext/Errno/ChangeLog @@ -0,0 +1,50 @@ +Change 170 on 1998/07/05 by (Graham Barr) + + Fixed three problems reported by Hans Mulder for NeXT + + - Errno_pm.PL does not recognize #define lines because they have + whitespace before the '#'. ANSI does not allow that in portable + code; that didn't stop the author of NeXT's . + + - Cpp output lines look like this: #1 "errno.c" + Errno_pm.PL does not recognize that format; it wants whitespace + before the line number. + + - Cpp does a syntax check on files with names ending in ".c"; it + reports fatal errors on input lines like: "ENOSYS" [[ENOSYS]] + Workaround: use $Config{cppstdin}, like Errno 1.04 did. + +Change 160 on 1998/06/27 by (Graham Barr) + + - Added patch from Sarathy to support Win32 + - Changed use of $Config{cpp} to $Config{cpprun} as suggested by + Tom Horsley + +Change 159 on 1998/06/27 by (Graham Barr) + + - Changed to use cpp to locate required files + - Moved dummy Errno.pm file into d/ + - Added support for VMS + +Change 158 on 1998/06/27 by (Graham Barr) + + Rename errno.pl to Errno_pm.PL + +Change 146 on 1998/05/31 by (Graham Barr) + + Added ChangeLog to MANIFEST + +Change 140 on 1998/05/23 by (Graham Barr) + + Fix type in errno.pl + +Change 139 on 1998/05/23 by (Graham Barr) + + Moved code to generate Errno.pm into errno.pl + +Change 136 on 1998/05/19 by (Graham Barr) + + Changed to use cpp to locate constants + + Added t/errno.t + diff --git a/contrib/perl5/ext/Errno/Errno_pm.PL b/contrib/perl5/ext/Errno/Errno_pm.PL new file mode 100644 index 0000000..f4d5020 --- /dev/null +++ b/contrib/perl5/ext/Errno/Errno_pm.PL @@ -0,0 +1,276 @@ +use ExtUtils::MakeMaker; +use Config; +use strict; + +use vars qw($VERSION); + +$VERSION = "1.09"; + +my %err = (); + +unlink "Errno.pm" if -f "Errno.pm"; +open OUT, ">Errno.pm" or die "Cannot open Errno.pm: $!"; +select OUT; +my $file; +foreach $file (get_files()) { + process_file($file); +} +write_errno_pm(); +unlink "errno.c" if -f "errno.c"; + +sub process_file { + my($file) = @_; + + return unless defined $file; + + local *FH; + if (($^O eq 'VMS') && ($Config{vms_cc_type} ne 'gnuc')) { + unless(open(FH," LIBRARY/EXTRACT=ERRNO/OUTPUT=SYS\$OUTPUT $file |")) { + warn "Cannot open '$file'"; + return; + } + } else { + unless(open(FH,"< $file")) { + warn "Cannot open '$file'"; + return; + } + } + while() { + $err{$1} = 1 + if /^\s*#\s*define\s+(E\w+)\s+/; + } + close(FH); +} + +sub get_files { + my %file = (); + # VMS keeps its include files in system libraries (well, except for Gcc) + if ($^O eq 'VMS') { + if ($Config{vms_cc_type} eq 'decc') { + $file{'Sys$Library:DECC$RTLDEF.TLB'} = 1; + } elsif ($Config{vms_cc_type} eq 'vaxc') { + $file{'Sys$Library:vaxcdef.tlb'} = 1; + } elsif ($Config{vms_cc_type} eq 'gcc') { + $file{'gnu_cc_include:[000000]errno.h'} = 1; + } + } elsif ($^O eq 'os390') { + # OS/390 C compiler doesn't generate #file or #line directives + $file{'/usr/include/errno.h'} = 1; + } else { + open(CPPI,"> errno.c") or + die "Cannot open errno.c"; + + print CPPI "#include \n"; + + close(CPPI); + + # invoke CPP and read the output + + open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or + die "Cannot exec $Config{cpprun}"; + + my $pat; + if ($^O eq 'MSWin32' and $Config{cc} =~ /^bcc/i) { + $pat = '^/\*\s+(.+)\s+\d+\s*:\s+\*/'; + } + else { + $pat = '^#(?:line)?\s*\d+\s+"([^"]+)"'; + } + while() { + $file{$1} = 1 if /$pat/o; + } + close(CPPO); + } + return keys %file; +} + +sub write_errno_pm { + my $err; + + # create the CPP input + + open(CPPI,"> errno.c") or + die "Cannot open errno.c"; + + print CPPI "#include \n"; + + foreach $err (keys %err) { + print CPPI '"',$err,'" [[',$err,']]',"\n"; + } + + close(CPPI); + + # invoke CPP and read the output + + if ($^O eq 'VMS') { + my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}"; + $cpp =~ s/sys\$input//i; + open(CPPO,"$cpp errno.c |") or + die "Cannot exec $Config{cppstdin}"; + } elsif(!$Config{'cpprun'} or $^O eq 'next') { + # NeXT will do syntax checking unless it is reading from stdin + my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}"; + open(CPPO,"$cpp < errno.c |") + or die "Cannot exec $cpp"; + } else { + open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or + die "Cannot exec $Config{cpprun}"; + } + + %err = (); + + while() { + my($name,$expr); + next unless ($name, $expr) = /"(.*?)"\s*\[\s*\[\s*(.*?)\s*\]\s*\]/; + next if $name eq $expr; + $err{$name} = eval $expr; + } + close(CPPO); + + # Write Errno.pm + + print <<"EDQ"; +# +# This file is auto-generated. ***ANY*** changes here will be lost +# + +package Errno; +use vars qw(\@EXPORT_OK \%EXPORT_TAGS \@ISA \$VERSION \%errno \$AUTOLOAD); +use Exporter (); +use Config; +use strict; + +\$Config{'myarchname'} eq "$Config{'myarchname'}" or + die "Errno architecture ($Config{'myarchname'}) does not match executable architecture (\$Config{'myarchname'})"; + +\$VERSION = "$VERSION"; +\@ISA = qw(Exporter); + +EDQ + + my $len = 0; + my @err = sort { $err{$a} <=> $err{$b} } keys %err; + map { $len = length if length > $len } @err; + + my $j = "\@EXPORT_OK = qw(" . join(" ",keys %err) . ");\n"; + $j =~ s/(.{50,70})\s/$1\n\t/g; + print $j,"\n"; + +print <<'ESQ'; +%EXPORT_TAGS = ( + POSIX => [qw( +ESQ + + my $k = join(" ", grep { exists $err{$_} } + qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT + EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED + ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT + EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS + EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK + EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH + ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM + ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR + ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM + EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE + ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT + ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY + EUSERS EWOULDBLOCK EXDEV)); + + $k =~ s/(.{50,70})\s/$1\n\t/g; + print "\t",$k,"\n )]\n);\n\n"; + + foreach $err (@err) { + printf "sub %s () { %d }\n",,$err,$err{$err}; + } + + print <<'ESQ'; + +sub TIEHASH { bless [] } + +sub FETCH { + my ($self, $errname) = @_; + my $proto = prototype("Errno::$errname"); + if (defined($proto) && $proto eq "") { + no strict 'refs'; + return $! == &$errname; + } + require Carp; + Carp::confess("No errno $errname"); +} + +sub STORE { + require Carp; + Carp::confess("ERRNO hash is read only!"); +} + +*CLEAR = \&STORE; +*DELETE = \&STORE; + +sub NEXTKEY { + my($k,$v); + while(($k,$v) = each %Errno::) { + my $proto = prototype("Errno::$k"); + last if (defined($proto) && $proto eq ""); + + } + $k +} + +sub FIRSTKEY { + my $s = scalar keys %Errno::; + goto &NEXTKEY; +} + +sub EXISTS { + my ($self, $errname) = @_; + my $proto = prototype($errname); + defined($proto) && $proto eq ""; +} + +tie %!, __PACKAGE__; + +1; +__END__ + +=head1 NAME + +Errno - System errno constants + +=head1 SYNOPSIS + + use Errno qw(EINTR EIO :POSIX); + +=head1 DESCRIPTION + +C defines and conditionally exports all the error constants +defined in your system C include file. It has a single export +tag, C<:POSIX>, which will export all POSIX defined error numbers. + +C also makes C<%!> magic such that each element of C<%!> has a non-zero +value only if C<$!> is set to that value, eg + + use Errno; + + unless (open(FH, "/fangorn/spouse")) { + if ($!{ENOENT}) { + warn "Get a wife!\n"; + } else { + warn "This path is barred: $!"; + } + } + +=head1 AUTHOR + +Graham Barr + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr. All rights reserved. +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + +ESQ + +} diff --git a/contrib/perl5/ext/Errno/Makefile.PL b/contrib/perl5/ext/Errno/Makefile.PL new file mode 100644 index 0000000..ffc8c4b --- /dev/null +++ b/contrib/perl5/ext/Errno/Makefile.PL @@ -0,0 +1,29 @@ +use ExtUtils::MakeMaker; + +@VMS = ($^O eq 'VMS') ? (MAN3PODS => ' ') : (); + +WriteMakefile( + NAME => 'Errno', + VERSION_FROM => 'Errno_pm.PL', + PL_FILES => {'Errno_pm.PL'=>'Errno.pm'}, + PM => {'Errno.pm' => '$(INST_LIBDIR)/Errno.pm'}, + 'clean' => {FILES => 'Errno.pm'}, + 'dist' => { + COMPRESS => 'gzip -9f', + SUFFIX => '.gz', + DIST_DEFAULT => 'd/Errno.pm tardist', + }, + @VMS, +); + +sub MY::postamble { + my $TARG = MM->catfile('d','Errno.pm'); +qq!$TARG : Makefile + echo '#This is a dummy file so CPAN will find a VERSION' > $TARG + echo 'package Errno;' >> $TARG + echo '\$\$VERSION = "\$(VERSION)";' >>$TARG + echo '#This is to make sure require will return an error' >>$TARG + echo '0;' >>$TARG + +! +} diff --git a/contrib/perl5/ext/Fcntl/Fcntl.pm b/contrib/perl5/ext/Fcntl/Fcntl.pm new file mode 100644 index 0000000..f1edb8e --- /dev/null +++ b/contrib/perl5/ext/Fcntl/Fcntl.pm @@ -0,0 +1,137 @@ +package Fcntl; + +=head1 NAME + +Fcntl - load the C Fcntl.h defines + +=head1 SYNOPSIS + + use Fcntl; + use Fcntl qw(:DEFAULT :flock); + +=head1 DESCRIPTION + +This module is just a translation of the C F file. +Unlike the old mechanism of requiring a translated F +file, this uses the B program (see the Perl source distribution) +and your native C compiler. This means that it has a +far more likely chance of getting the numbers right. + +=head1 NOTE + +Only C<#define> symbols get translated; you must still correctly +pack up your own arguments to pass as args for locking functions, etc. + +=head1 EXPORTED SYMBOLS + +By default your system's F_* and O_* constants (eg, F_DUPFD and +O_CREAT) and the FD_CLOEXEC constant are exported into your namespace. + +You can request that the flock() constants (LOCK_SH, LOCK_EX, LOCK_NB +and LOCK_UN) be provided by using the tag C<:flock>. See L. + +You can request that the old constants (FAPPEND, FASYNC, FCREAT, +FDEFER, FEXCL, FNDELAY, FNONBLOCK, FSYNC, FTRUNC) be provided for +compatibility reasons by using the tag C<:Fcompat>. For new +applications the newer versions of these constants are suggested +(O_APPEND, O_ASYNC, O_CREAT, O_DEFER, O_EXCL, O_NDELAY, O_NONBLOCK, +O_SYNC, O_TRUNC). + +Please refer to your native fcntl() and open() documentation to see +what constants are implemented in your system. + +=cut + +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD); + +require Exporter; +require DynaLoader; +@ISA = qw(Exporter DynaLoader); +$VERSION = "1.03"; +# Items to export into callers namespace by default +# (move infrequently used names to @EXPORT_OK below) +@EXPORT = + qw( + FD_CLOEXEC + F_DUPFD + F_EXLCK + F_GETFD + F_GETFL + F_GETLK + F_GETOWN + F_POSIX + F_RDLCK + F_SETFD + F_SETFL + F_SETLK + F_SETLKW + F_SETOWN + F_SHLCK + F_UNLCK + F_WRLCK + O_ACCMODE + O_APPEND + O_ASYNC + O_BINARY + O_CREAT + O_DEFER + O_DSYNC + O_EXCL + O_EXLOCK + O_NDELAY + O_NOCTTY + O_NONBLOCK + O_RDONLY + O_RDWR + O_RSYNC + O_SHLOCK + O_SYNC + O_TEXT + O_TRUNC + O_WRONLY + ); + +# Other items we are prepared to export if requested +@EXPORT_OK = qw( + FAPPEND + FASYNC + FCREAT + FDEFER + FEXCL + FNDELAY + FNONBLOCK + FSYNC + FTRUNC + LOCK_EX + LOCK_NB + LOCK_SH + LOCK_UN +); +# Named groups of exports +%EXPORT_TAGS = ( + 'flock' => [qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN)], + 'Fcompat' => [qw(FAPPEND FASYNC FCREAT FDEFER FEXCL + FNDELAY FNONBLOCK FSYNC FTRUNC)], +); + +sub AUTOLOAD { + (my $constname = $AUTOLOAD) =~ s/.*:://; + my $val = constant($constname, 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + my ($pack,$file,$line) = caller; + die "Your vendor has not defined Fcntl macro $constname, used at $file line $line. +"; + } + } + *$AUTOLOAD = sub { $val }; + goto &$AUTOLOAD; +} + +bootstrap Fcntl $VERSION; + +1; diff --git a/contrib/perl5/ext/Fcntl/Fcntl.xs b/contrib/perl5/ext/Fcntl/Fcntl.xs new file mode 100644 index 0000000..5149444 --- /dev/null +++ b/contrib/perl5/ext/Fcntl/Fcntl.xs @@ -0,0 +1,377 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifdef VMS +# include +#else +#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32) +#define _NO_OLDNAMES +#endif +# include +#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32) +#undef _NO_OLDNAMES +#endif +#endif + +/* This comment is a kludge to get metaconfig to see the symbols + VAL_O_NONBLOCK + VAL_EAGAIN + RD_NODATA + EOF_NONBLOCK + and include the appropriate metaconfig unit + so that Configure will test how to turn on non-blocking I/O + for a file descriptor. See config.h for how to use these + in your extension. + + While I'm at it, I'll have metaconfig look for HAS_POLL too. + --AD October 16, 1995 +*/ + +static int +not_here(char *s) +{ + croak("%s not implemented on this architecture", s); + return -1; +} + +static double +constant(char *name, int arg) +{ + errno = 0; + switch (*name) { + case 'F': + if (strnEQ(name, "F_", 2)) { + if (strEQ(name, "F_DUPFD")) +#ifdef F_DUPFD + return F_DUPFD; +#else + goto not_there; +#endif + if (strEQ(name, "F_EXLCK")) +#ifdef F_EXLCK + return F_EXLCK; +#else + goto not_there; +#endif + if (strEQ(name, "F_GETFD")) +#ifdef F_GETFD + return F_GETFD; +#else + goto not_there; +#endif + if (strEQ(name, "F_GETFL")) +#ifdef F_GETFL + return F_GETFL; +#else + goto not_there; +#endif + if (strEQ(name, "F_GETLK")) +#ifdef F_GETLK + return F_GETLK; +#else + goto not_there; +#endif + if (strEQ(name, "F_GETOWN")) +#ifdef F_GETOWN + return F_GETOWN; +#else + goto not_there; +#endif + if (strEQ(name, "F_POSIX")) +#ifdef F_POSIX + return F_POSIX; +#else + goto not_there; +#endif + if (strEQ(name, "F_RDLCK")) +#ifdef F_RDLCK + return F_RDLCK; +#else + goto not_there; +#endif + if (strEQ(name, "F_SETFD")) +#ifdef F_SETFD + return F_SETFD; +#else + goto not_there; +#endif + if (strEQ(name, "F_SETFL")) +#ifdef F_SETFL + return F_SETFL; +#else + goto not_there; +#endif + if (strEQ(name, "F_SETLK")) +#ifdef F_SETLK + return F_SETLK; +#else + goto not_there; +#endif + if (strEQ(name, "F_SETLKW")) +#ifdef F_SETLKW + return F_SETLKW; +#else + goto not_there; +#endif + if (strEQ(name, "F_SETOWN")) +#ifdef F_SETOWN + return F_SETOWN; +#else + goto not_there; +#endif + if (strEQ(name, "F_SHLCK")) +#ifdef F_SHLCK + return F_SHLCK; +#else + goto not_there; +#endif + if (strEQ(name, "F_UNLCK")) +#ifdef F_UNLCK + return F_UNLCK; +#else + goto not_there; +#endif + if (strEQ(name, "F_WRLCK")) +#ifdef F_WRLCK + return F_WRLCK; +#else + goto not_there; +#endif + errno = EINVAL; + return 0; + } + if (strEQ(name, "FAPPEND")) +#ifdef FAPPEND + return FAPPEND; +#else + goto not_there; +#endif + if (strEQ(name, "FASYNC")) +#ifdef FASYNC + return FASYNC; +#else + goto not_there; +#endif + if (strEQ(name, "FCREAT")) +#ifdef FCREAT + return FCREAT; +#else + goto not_there; +#endif + if (strEQ(name, "FD_CLOEXEC")) +#ifdef FD_CLOEXEC + return FD_CLOEXEC; +#else + goto not_there; +#endif + if (strEQ(name, "FDEFER")) +#ifdef FDEFER + return FDEFER; +#else + goto not_there; +#endif + if (strEQ(name, "FEXCL")) +#ifdef FEXCL + return FEXCL; +#else + goto not_there; +#endif + if (strEQ(name, "FNDELAY")) +#ifdef FNDELAY + return FNDELAY; +#else + goto not_there; +#endif + if (strEQ(name, "FNONBLOCK")) +#ifdef FNONBLOCK + return FNONBLOCK; +#else + goto not_there; +#endif + if (strEQ(name, "FSYNC")) +#ifdef FSYNC + return FSYNC; +#else + goto not_there; +#endif + if (strEQ(name, "FTRUNC")) +#ifdef FTRUNC + return FTRUNC; +#else + goto not_there; +#endif + break; + case 'L': + if (strnEQ(name, "LOCK_", 5)) { + /* We support flock() on systems which don't have it, so + always supply the constants. */ + if (strEQ(name, "LOCK_SH")) +#ifdef LOCK_SH + return LOCK_SH; +#else + return 1; +#endif + if (strEQ(name, "LOCK_EX")) +#ifdef LOCK_EX + return LOCK_EX; +#else + return 2; +#endif + if (strEQ(name, "LOCK_NB")) +#ifdef LOCK_NB + return LOCK_NB; +#else + return 4; +#endif + if (strEQ(name, "LOCK_UN")) +#ifdef LOCK_UN + return LOCK_UN; +#else + return 8; +#endif + } else + goto not_there; + break; + case 'O': + if (strnEQ(name, "O_", 2)) { + if (strEQ(name, "O_ACCMODE")) +#ifdef O_ACCMODE + return O_ACCMODE; +#else + goto not_there; +#endif + if (strEQ(name, "O_APPEND")) +#ifdef O_APPEND + return O_APPEND; +#else + goto not_there; +#endif + if (strEQ(name, "O_ASYNC")) +#ifdef O_ASYNC + return O_ASYNC; +#else + goto not_there; +#endif + if (strEQ(name, "O_BINARY")) +#ifdef O_BINARY + return O_BINARY; +#else + goto not_there; +#endif + if (strEQ(name, "O_CREAT")) +#ifdef O_CREAT + return O_CREAT; +#else + goto not_there; +#endif + if (strEQ(name, "O_DEFER")) +#ifdef O_DEFER + return O_DEFER; +#else + goto not_there; +#endif + if (strEQ(name, "O_DSYNC")) +#ifdef O_DSYNC + return O_DSYNC; +#else + goto not_there; +#endif + if (strEQ(name, "O_EXCL")) +#ifdef O_EXCL + return O_EXCL; +#else + goto not_there; +#endif + if (strEQ(name, "O_EXLOCK")) +#ifdef O_EXLOCK + return O_EXLOCK; +#else + goto not_there; +#endif + if (strEQ(name, "O_NDELAY")) +#ifdef O_NDELAY + return O_NDELAY; +#else + goto not_there; +#endif + if (strEQ(name, "O_NOCTTY")) +#ifdef O_NOCTTY + return O_NOCTTY; +#else + goto not_there; +#endif + if (strEQ(name, "O_NONBLOCK")) +#ifdef O_NONBLOCK + return O_NONBLOCK; +#else + goto not_there; +#endif + if (strEQ(name, "O_RDONLY")) +#ifdef O_RDONLY + return O_RDONLY; +#else + goto not_there; +#endif + if (strEQ(name, "O_RDWR")) +#ifdef O_RDWR + return O_RDWR; +#else + goto not_there; +#endif + if (strEQ(name, "O_RSYNC")) +#ifdef O_RSYNC + return O_RSYNC; +#else + goto not_there; +#endif + if (strEQ(name, "O_SHLOCK")) +#ifdef O_SHLOCK + return O_SHLOCK; +#else + goto not_there; +#endif + if (strEQ(name, "O_SYNC")) +#ifdef O_SYNC + return O_SYNC; +#else + goto not_there; +#endif + if (strEQ(name, "O_TEXT")) +#ifdef O_TEXT + return O_TEXT; +#else + goto not_there; +#endif + if (strEQ(name, "O_TRUNC")) +#ifdef O_TRUNC + return O_TRUNC; +#else + goto not_there; +#endif + if (strEQ(name, "O_WRONLY")) +#ifdef O_WRONLY + return O_WRONLY; +#else + goto not_there; +#endif + } else + goto not_there; + break; + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + + +MODULE = Fcntl PACKAGE = Fcntl + +double +constant(name,arg) + char * name + int arg + diff --git a/contrib/perl5/ext/Fcntl/Makefile.PL b/contrib/perl5/ext/Fcntl/Makefile.PL new file mode 100644 index 0000000..66a6df6 --- /dev/null +++ b/contrib/perl5/ext/Fcntl/Makefile.PL @@ -0,0 +1,8 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => 'Fcntl', + MAN3PODS => ' ', # Pods will be built by installman. + XSPROTOARG => '-noprototypes', # XXX remove later? + VERSION_FROM => 'Fcntl.pm', +); + diff --git a/contrib/perl5/ext/GDBM_File/GDBM_File.pm b/contrib/perl5/ext/GDBM_File/GDBM_File.pm new file mode 100644 index 0000000..09df437 --- /dev/null +++ b/contrib/perl5/ext/GDBM_File/GDBM_File.pm @@ -0,0 +1,87 @@ +# GDBM_File.pm -- Perl 5 interface to GNU gdbm library. + +=head1 NAME + +GDBM_File - Perl5 access to the gdbm library. + +=head1 SYNOPSIS + + use GDBM_File ; + tie %hash, 'GDBM_File', $filename, &GDBM_WRCREAT, 0640; + # Use the %hash array. + untie %hash ; + +=head1 DESCRIPTION + +B is a module which allows Perl programs to make use of the +facilities provided by the GNU gdbm library. If you intend to use this +module you should really have a copy of the gdbm manualpage at hand. + +Most of the libgdbm.a functions are available through the GDBM_File +interface. + +=head1 AVAILABILITY + +Gdbm is available from any GNU archive. The master site is +C, but your are strongly urged to use one of the many +mirrors. You can obtain a list of mirror sites by issuing the +command C. + +=head1 BUGS + +The available functions and the gdbm/perl interface need to be documented. + +=head1 SEE ALSO + +L, L. + +=cut + +package GDBM_File; + +use strict; +use vars qw($VERSION @ISA @EXPORT $AUTOLOAD); + +require Carp; +require Tie::Hash; +require Exporter; +use AutoLoader; +require DynaLoader; +@ISA = qw(Tie::Hash Exporter DynaLoader); +@EXPORT = qw( + GDBM_CACHESIZE + GDBM_FAST + GDBM_INSERT + GDBM_NEWDB + GDBM_READER + GDBM_REPLACE + GDBM_WRCREAT + GDBM_WRITER +); + +$VERSION = "1.00"; + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + Carp::croak("Your vendor has not defined GDBM_File macro $constname, used"); + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +bootstrap GDBM_File $VERSION; + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. + +1; +__END__ diff --git a/contrib/perl5/ext/GDBM_File/GDBM_File.xs b/contrib/perl5/ext/GDBM_File/GDBM_File.xs new file mode 100644 index 0000000..ac1ca8c --- /dev/null +++ b/contrib/perl5/ext/GDBM_File/GDBM_File.xs @@ -0,0 +1,243 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include +#include + +typedef GDBM_FILE GDBM_File; + +#define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */ +#define gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func) \ + gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func) + +#define gdbm_FETCH(db,key) gdbm_fetch(db,key) +#define gdbm_STORE(db,key,value,flags) gdbm_store(db,key,value,flags) +#define gdbm_DELETE(db,key) gdbm_delete(db,key) +#define gdbm_FIRSTKEY(db) gdbm_firstkey(db) +#define gdbm_NEXTKEY(db,key) gdbm_nextkey(db,key) +#define gdbm_EXISTS(db,key) gdbm_exists(db,key) + +typedef datum gdatum; + +typedef void (*FATALFUNC)(); + +static int +not_here(char *s) +{ + croak("GDBM_File::%s not implemented on this architecture", s); + return -1; +} + +/* Versions of gdbm prior to 1.7x might not have the gdbm_sync, + gdbm_exists, and gdbm_setopt functions. Apparently Slackware + (Linux) 2.1 contains gdbm-1.5 (which dates back to 1991). +*/ +#ifndef GDBM_FAST +#define gdbm_exists(db,key) not_here("gdbm_exists") +#define gdbm_sync(db) (void) not_here("gdbm_sync") +#define gdbm_setopt(db,optflag,optval,optlen) not_here("gdbm_setopt") +#endif + +static double +constant(char *name, int arg) +{ + errno = 0; + switch (*name) { + case 'A': + break; + case 'B': + break; + case 'C': + break; + case 'D': + break; + case 'E': + break; + case 'F': + break; + case 'G': + if (strEQ(name, "GDBM_CACHESIZE")) +#ifdef GDBM_CACHESIZE + return GDBM_CACHESIZE; +#else + goto not_there; +#endif + if (strEQ(name, "GDBM_FAST")) +#ifdef GDBM_FAST + return GDBM_FAST; +#else + goto not_there; +#endif + if (strEQ(name, "GDBM_FASTMODE")) +#ifdef GDBM_FASTMODE + return GDBM_FASTMODE; +#else + goto not_there; +#endif + if (strEQ(name, "GDBM_INSERT")) +#ifdef GDBM_INSERT + return GDBM_INSERT; +#else + goto not_there; +#endif + if (strEQ(name, "GDBM_NEWDB")) +#ifdef GDBM_NEWDB + return GDBM_NEWDB; +#else + goto not_there; +#endif + if (strEQ(name, "GDBM_READER")) +#ifdef GDBM_READER + return GDBM_READER; +#else + goto not_there; +#endif + if (strEQ(name, "GDBM_REPLACE")) +#ifdef GDBM_REPLACE + return GDBM_REPLACE; +#else + goto not_there; +#endif + if (strEQ(name, "GDBM_WRCREAT")) +#ifdef GDBM_WRCREAT + return GDBM_WRCREAT; +#else + goto not_there; +#endif + if (strEQ(name, "GDBM_WRITER")) +#ifdef GDBM_WRITER + return GDBM_WRITER; +#else + goto not_there; +#endif + break; + case 'H': + break; + case 'I': + break; + case 'J': + break; + case 'K': + break; + case 'L': + break; + case 'M': + break; + case 'N': + break; + case 'O': + break; + case 'P': + break; + case 'Q': + break; + case 'R': + break; + case 'S': + break; + case 'T': + break; + case 'U': + break; + case 'V': + break; + case 'W': + break; + case 'X': + break; + case 'Y': + break; + case 'Z': + break; + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +MODULE = GDBM_File PACKAGE = GDBM_File PREFIX = gdbm_ + +double +constant(name,arg) + char * name + int arg + + +GDBM_File +gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak) + char * dbtype + char * name + int read_write + int mode + FATALFUNC fatal_func + +void +gdbm_close(db) + GDBM_File db + CLEANUP: + +void +gdbm_DESTROY(db) + GDBM_File db + CODE: + gdbm_close(db); + +gdatum +gdbm_FETCH(db, key) + GDBM_File db + datum key + +int +gdbm_STORE(db, key, value, flags = GDBM_REPLACE) + GDBM_File db + datum key + datum value + int flags + CLEANUP: + if (RETVAL) { + if (RETVAL < 0 && errno == EPERM) + croak("No write permission to gdbm file"); + croak("gdbm store returned %d, errno %d, key \"%.*s\"", + RETVAL,errno,key.dsize,key.dptr); + /* gdbm_clearerr(db); */ + } + +int +gdbm_DELETE(db, key) + GDBM_File db + datum key + +gdatum +gdbm_FIRSTKEY(db) + GDBM_File db + +gdatum +gdbm_NEXTKEY(db, key) + GDBM_File db + datum key + +int +gdbm_reorganize(db) + GDBM_File db + + +void +gdbm_sync(db) + GDBM_File db + +int +gdbm_EXISTS(db, key) + GDBM_File db + datum key + +int +gdbm_setopt (db, optflag, optval, optlen) + GDBM_File db + int optflag + int &optval + int optlen + diff --git a/contrib/perl5/ext/GDBM_File/Makefile.PL b/contrib/perl5/ext/GDBM_File/Makefile.PL new file mode 100644 index 0000000..d244613 --- /dev/null +++ b/contrib/perl5/ext/GDBM_File/Makefile.PL @@ -0,0 +1,8 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => 'GDBM_File', + LIBS => ["-L/usr/local/lib -lgdbm", "-ldbm"], + MAN3PODS => ' ', # Pods will be built by installman. + XSPROTOARG => '-noprototypes', # XXX remove later? + VERSION_FROM => 'GDBM_File.pm', +); diff --git a/contrib/perl5/ext/GDBM_File/typemap b/contrib/perl5/ext/GDBM_File/typemap new file mode 100644 index 0000000..317a8f3 --- /dev/null +++ b/contrib/perl5/ext/GDBM_File/typemap @@ -0,0 +1,27 @@ +# +#################################### DBM SECTION +# + +datum T_DATUM +gdatum T_GDATUM +NDBM_File T_PTROBJ +GDBM_File T_PTROBJ +SDBM_File T_PTROBJ +ODBM_File T_PTROBJ +DB_File T_PTROBJ +DBZ_File T_PTROBJ +FATALFUNC T_OPAQUEPTR + +INPUT +T_DATUM + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; +T_GDATUM + UNIMPLEMENTED +OUTPUT +T_DATUM + sv_setpvn($arg, $var.dptr, $var.dsize); +T_GDATUM + sv_usepvn($arg, $var.dptr, $var.dsize); +T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/contrib/perl5/ext/IO/IO.pm b/contrib/perl5/ext/IO/IO.pm new file mode 100644 index 0000000..4d4c81c --- /dev/null +++ b/contrib/perl5/ext/IO/IO.pm @@ -0,0 +1,36 @@ +# + +package IO; + +=head1 NAME + +IO - load various IO modules + +=head1 SYNOPSIS + + use IO; + +=head1 DESCRIPTION + +C provides a simple mechanism to load some of the IO modules at one go. +Currently this includes: + + IO::Handle + IO::Seekable + IO::File + IO::Pipe + IO::Socket + +For more information on any of these modules, please see its respective +documentation. + +=cut + +use IO::Handle; +use IO::Seekable; +use IO::File; +use IO::Pipe; +use IO::Socket; + +1; + diff --git a/contrib/perl5/ext/IO/IO.xs b/contrib/perl5/ext/IO/IO.xs new file mode 100644 index 0000000..a434cca --- /dev/null +++ b/contrib/perl5/ext/IO/IO.xs @@ -0,0 +1,292 @@ +#include "EXTERN.h" +#define PERLIO_NOT_STDIO 1 +#include "perl.h" +#include "XSUB.h" + +#ifdef I_UNISTD +# include +#endif +#ifdef I_FCNTL +#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32) +#define _NO_OLDNAMES +#endif +# include +#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32) +#undef _NO_OLDNAMES +#endif + +#endif + +#ifdef PerlIO +typedef int SysRet; +typedef PerlIO * InputStream; +typedef PerlIO * OutputStream; +#else +#define PERLIO_IS_STDIO 1 +typedef int SysRet; +typedef FILE * InputStream; +typedef FILE * OutputStream; +#endif + +static int +not_here(char *s) +{ + croak("%s not implemented on this architecture", s); + return -1; +} + +static bool +constant(char *name, IV *pval) +{ + switch (*name) { + case '_': + if (strEQ(name, "_IOFBF")) +#ifdef _IOFBF + { *pval = _IOFBF; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "_IOLBF")) +#ifdef _IOLBF + { *pval = _IOLBF; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "_IONBF")) +#ifdef _IONBF + { *pval = _IONBF; return TRUE; } +#else + return FALSE; +#endif + break; + case 'S': + if (strEQ(name, "SEEK_SET")) +#ifdef SEEK_SET + { *pval = SEEK_SET; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "SEEK_CUR")) +#ifdef SEEK_CUR + { *pval = SEEK_CUR; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "SEEK_END")) +#ifdef SEEK_END + { *pval = SEEK_END; return TRUE; } +#else + return FALSE; +#endif + break; + } + + return FALSE; +} + + +MODULE = IO PACKAGE = IO::Seekable PREFIX = f + +SV * +fgetpos(handle) + InputStream handle + CODE: + if (handle) { + Fpos_t pos; +#ifdef PerlIO + PerlIO_getpos(handle, &pos); +#else + fgetpos(handle, &pos); +#endif + ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); + } + else { + ST(0) = &PL_sv_undef; + errno = EINVAL; + } + +SysRet +fsetpos(handle, pos) + InputStream handle + SV * pos + CODE: + char *p; + if (handle && (p = SvPVx(pos, PL_na)) && PL_na == sizeof(Fpos_t)) +#ifdef PerlIO + RETVAL = PerlIO_setpos(handle, (Fpos_t*)p); +#else + RETVAL = fsetpos(handle, (Fpos_t*)p); +#endif + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +MODULE = IO PACKAGE = IO::File PREFIX = f + +SV * +new_tmpfile(packname = "IO::File") + char * packname + PREINIT: + OutputStream fp; + GV *gv; + CODE: +#ifdef PerlIO + fp = PerlIO_tmpfile(); +#else + fp = tmpfile(); +#endif + gv = (GV*)SvREFCNT_inc(newGVgen(packname)); + hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD); + if (do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) { + ST(0) = sv_2mortal(newRV((SV*)gv)); + sv_bless(ST(0), gv_stashpv(packname, TRUE)); + SvREFCNT_dec(gv); /* undo increment in newRV() */ + } + else { + ST(0) = &PL_sv_undef; + SvREFCNT_dec(gv); + } + +MODULE = IO PACKAGE = IO::Handle PREFIX = f + +SV * +constant(name) + char * name + CODE: + IV i; + if (constant(name, &i)) + ST(0) = sv_2mortal(newSViv(i)); + else + ST(0) = &PL_sv_undef; + +int +ungetc(handle, c) + InputStream handle + int c + CODE: + if (handle) +#ifdef PerlIO + RETVAL = PerlIO_ungetc(handle, c); +#else + RETVAL = ungetc(c, handle); +#endif + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +int +ferror(handle) + InputStream handle + CODE: + if (handle) +#ifdef PerlIO + RETVAL = PerlIO_error(handle); +#else + RETVAL = ferror(handle); +#endif + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +int +clearerr(handle) + InputStream handle + CODE: + if (handle) { +#ifdef PerlIO + PerlIO_clearerr(handle); +#else + clearerr(handle); +#endif + RETVAL = 0; + } + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +int +untaint(handle) + SV * handle + CODE: +#ifdef IOf_UNTAINT + IO * io; + io = sv_2io(handle); + if (io) { + IoFLAGS(io) |= IOf_UNTAINT; + RETVAL = 0; + } + else { +#endif + RETVAL = -1; + errno = EINVAL; +#ifdef IOf_UNTAINT + } +#endif + OUTPUT: + RETVAL + +SysRet +fflush(handle) + OutputStream handle + CODE: + if (handle) +#ifdef PerlIO + RETVAL = PerlIO_flush(handle); +#else + RETVAL = Fflush(handle); +#endif + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +void +setbuf(handle, buf) + OutputStream handle + char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0; + CODE: + if (handle) +#ifdef PERLIO_IS_STDIO + setbuf(handle, buf); +#else + not_here("IO::Handle::setbuf"); +#endif + +SysRet +setvbuf(handle, buf, type, size) + OutputStream handle + char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0; + int type + int size + CODE: +/* Should check HAS_SETVBUF once Configure tests for that */ +#if defined(PERLIO_IS_STDIO) && defined(_IOFBF) + if (!handle) /* Try input stream. */ + handle = IoIFP(sv_2io(ST(0))); + if (handle) + RETVAL = setvbuf(handle, buf, type, size); + else { + RETVAL = -1; + errno = EINVAL; + } +#else + RETVAL = (SysRet) not_here("IO::Handle::setvbuf"); +#endif + OUTPUT: + RETVAL + + diff --git a/contrib/perl5/ext/IO/Makefile.PL b/contrib/perl5/ext/IO/Makefile.PL new file mode 100644 index 0000000..4a34be6 --- /dev/null +++ b/contrib/perl5/ext/IO/Makefile.PL @@ -0,0 +1,8 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => 'IO', + MAN3PODS => ' ', # Pods will be built by installman. + XSPROTOARG => '-noprototypes', # XXX remove later? + VERSION_FROM => 'lib/IO/Handle.pm', + XS_VERSION => 1.15 +); diff --git a/contrib/perl5/ext/IO/README b/contrib/perl5/ext/IO/README new file mode 100644 index 0000000..e855afa --- /dev/null +++ b/contrib/perl5/ext/IO/README @@ -0,0 +1,4 @@ +This directory contains files from the IO distribution maintained by +Graham Barr . If you find that you have to modify +any files in this directory then please forward him a patch for only +the files in this directory. diff --git a/contrib/perl5/ext/IO/lib/IO/File.pm b/contrib/perl5/ext/IO/lib/IO/File.pm new file mode 100644 index 0000000..de7fabc --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/File.pm @@ -0,0 +1,167 @@ +# + +package IO::File; + +=head1 NAME + +IO::File - supply object methods for filehandles + +=head1 SYNOPSIS + + use IO::File; + + $fh = new IO::File; + if ($fh->open("< file")) { + print <$fh>; + $fh->close; + } + + $fh = new IO::File "> file"; + if (defined $fh) { + print $fh "bar\n"; + $fh->close; + } + + $fh = new IO::File "file", "r"; + if (defined $fh) { + print <$fh>; + undef $fh; # automatically closes the file + } + + $fh = new IO::File "file", O_WRONLY|O_APPEND; + if (defined $fh) { + print $fh "corge\n"; + + $pos = $fh->getpos; + $fh->setpos($pos); + + undef $fh; # automatically closes the file + } + + autoflush STDOUT 1; + +=head1 DESCRIPTION + +C inherits from C and C. It extends +these classes with methods that are specific to file handles. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ([ ARGS ] ) + +Creates a C. If it receives any parameters, they are passed to +the method C; if the open fails, the object is destroyed. Otherwise, +it is returned to the caller. + +=item new_tmpfile + +Creates an C opened for read/write on a newly created temporary +file. On systems where this is possible, the temporary file is anonymous +(i.e. it is unlinked after creation, but held open). If the temporary +file cannot be created or opened, the C object is destroyed. +Otherwise, it is returned to the caller. + +=back + +=head1 METHODS + +=over 4 + +=item open( FILENAME [,MODE [,PERMS]] ) + +C accepts one, two or three parameters. With one parameter, +it is just a front end for the built-in C function. With two +parameters, the first parameter is a filename that may include +whitespace or other special characters, and the second parameter is +the open mode, optionally followed by a file permission value. + +If C receives a Perl mode string ("E", "+E", etc.) +or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic +Perl C operator. + +If C is given a numeric mode, it passes that mode +and the optional permissions value to the Perl C operator. +For convenience, C tries to import the O_XXX +constants from the Fcntl module. If dynamic loading is not available, +this may fail, but the rest of IO::File will still work. + +=back + +=head1 SEE ALSO + +L, +L, +L +L + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr EFE. + +=cut + +require 5.000; +use strict; +use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA); +use Carp; +use Symbol; +use SelectSaver; +use IO::Seekable; + +require Exporter; +require DynaLoader; + +@ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader); + +$VERSION = "1.06021"; + +@EXPORT = @IO::Seekable::EXPORT; + +eval { + # Make all Fcntl O_XXX constants available for importing + require Fcntl; + my @O = grep /^O_/, @Fcntl::EXPORT; + Fcntl->import(@O); # first we import what we want to export + push(@EXPORT, @O); +}; + + +################################################ +## Constructor +## + +sub new { + my $type = shift; + my $class = ref($type) || $type || "IO::File"; + @_ >= 0 && @_ <= 3 + or croak "usage: new $class [FILENAME [,MODE [,PERMS]]]"; + my $fh = $class->SUPER::new(); + if (@_) { + $fh->open(@_) + or return undef; + } + $fh; +} + +################################################ +## Open +## + +sub open { + @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])'; + my ($fh, $file) = @_; + if (@_ > 2) { + my ($mode, $perms) = @_[2, 3]; + if ($mode =~ /^\d+$/) { + defined $perms or $perms = 0666; + return sysopen($fh, $file, $mode, $perms); + } + $file = './' . $file if $file =~ m{\A[^\\/\w]}; + $file = IO::Handle::_open_mode_string($mode) . " $file\0"; + } + open($fh, $file); +} + +1; diff --git a/contrib/perl5/ext/IO/lib/IO/Handle.pm b/contrib/perl5/ext/IO/lib/IO/Handle.pm new file mode 100644 index 0000000..7927641 --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/Handle.pm @@ -0,0 +1,539 @@ + +package IO::Handle; + +=head1 NAME + +IO::Handle - supply object methods for I/O handles + +=head1 SYNOPSIS + + use IO::Handle; + + $fh = new IO::Handle; + if ($fh->fdopen(fileno(STDIN),"r")) { + print $fh->getline; + $fh->close; + } + + $fh = new IO::Handle; + if ($fh->fdopen(fileno(STDOUT),"w")) { + $fh->print("Some text\n"); + } + + use IO::Handle '_IOLBF'; + $fh->setvbuf($buffer_var, _IOLBF, 1024); + + undef $fh; # automatically closes the file if it's open + + autoflush STDOUT 1; + +=head1 DESCRIPTION + +C is the base class for all other IO handle classes. It is +not intended that objects of C would be created directly, +but instead C is inherited from by several other classes +in the IO hierarchy. + +If you are reading this documentation, looking for a replacement for +the C package, then I suggest you read the documentation +for C + +A C object is a reference to a symbol (see the C package) + +=head1 CONSTRUCTOR + +=over 4 + +=item new () + +Creates a new C object. + +=item new_from_fd ( FD, MODE ) + +Creates a C like C does. +It requires two parameters, which are passed to the method C; +if the fdopen fails, the object is destroyed. Otherwise, it is returned +to the caller. + +=back + +=head1 METHODS + +See L for complete descriptions of each of the following +supported C methods, which are just front ends for the +corresponding built-in functions: + + close + fileno + getc + eof + read + truncate + stat + print + printf + sysread + syswrite + +See L for complete descriptions of each of the following +supported C methods: + + autoflush + output_field_separator + output_record_separator + input_record_separator + input_line_number + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + format_line_break_characters + format_formfeed + format_write + +Furthermore, for doing normal I/O you might need these: + +=over + +=item $fh->fdopen ( FD, MODE ) + +C is like an ordinary C except that its first parameter +is not a filename but rather a file handle name, a IO::Handle object, +or a file descriptor number. + +=item $fh->opened + +Returns true if the object is currently a valid file descriptor. + +=item $fh->getline + +This works like <$fh> described in L +except that it's more readable and can be safely called in an +array context but still returns just one line. + +=item $fh->getlines + +This works like <$fh> when called in an array context to +read all the remaining lines in a file, except that it's more readable. +It will also croak() if accidentally called in a scalar context. + +=item $fh->ungetc ( ORD ) + +Pushes a character with the given ordinal value back onto the given +handle's input stream. + +=item $fh->write ( BUF, LEN [, OFFSET }\] ) + +This C is like C found in C, that is it is the +opposite of read. The wrapper for the perl C function is +called C. + +=item $fh->flush + +Flush the given handle's buffer. + +=item $fh->error + +Returns a true value if the given handle has experienced any errors +since it was opened or since the last call to C. + +=item $fh->clearerr + +Clear the given handle's error indicator. + +=back + +If the C functions setbuf() and/or setvbuf() are available, then +C and C set the buffering +policy for an IO::Handle. The calling sequences for the Perl functions +are the same as their C counterparts--including the constants C<_IOFBF>, +C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter +specifies a scalar variable to use as a buffer. WARNING: A variable +used as a buffer by C or C must not be modified in any +way until the IO::Handle is closed or C or C is called +again, or memory corruption may result! Note that you need to import +the constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. + +Lastly, there is a special method for working under B<-T> and setuid/gid +scripts: + +=over + +=item $fh->untaint + +Marks the object as taint-clean, and as such data read from it will also +be considered taint-clean. Note that this is a very trusting action to +take, and appropriate consideration for the data source and potential +vulnerability should be kept in mind. + +=back + +=head1 NOTE + +A C object is a GLOB reference. Some modules that +inherit from C may want to keep object related variables +in the hash table part of the GLOB. In an attempt to prevent modules +trampling on each other I propose the that any such module should prefix +its variables with its own name separated by _'s. For example the IO::Socket +module keeps a C variable in 'io_socket_timeout'. + +=head1 SEE ALSO + +L, +L, +L + +=head1 BUGS + +Due to backwards compatibility, all filehandles resemble objects +of class C, or actually classes derived from that class. +They actually aren't. Which means you can't derive your own +class from C and inherit those methods. + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr EFE + +=cut + +require 5.000; +use strict; +use vars qw($VERSION $XS_VERSION @EXPORT_OK $AUTOLOAD @ISA); +use Carp; +use Symbol; +use SelectSaver; + +require Exporter; +@ISA = qw(Exporter); + +$VERSION = "1.1505"; +$XS_VERSION = "1.15"; + +@EXPORT_OK = qw( + autoflush + output_field_separator + output_record_separator + input_record_separator + input_line_number + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + format_line_break_characters + format_formfeed + format_write + + print + printf + getline + getlines + + SEEK_SET + SEEK_CUR + SEEK_END + _IOFBF + _IOLBF + _IONBF +); + + +################################################ +## Interaction with the XS. +## + +require DynaLoader; +@IO::ISA = qw(DynaLoader); +bootstrap IO $XS_VERSION; + +sub AUTOLOAD { + if ($AUTOLOAD =~ /::(_?[a-z])/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD + } + my $constname = $AUTOLOAD; + $constname =~ s/.*:://; + my $val = constant($constname); + defined $val or croak "$constname is not a valid IO::Handle macro"; + no strict 'refs'; + *$AUTOLOAD = sub { $val }; + goto &$AUTOLOAD; +} + + +################################################ +## Constructors, destructors. +## + +sub new { + my $class = ref($_[0]) || $_[0] || "IO::Handle"; + @_ == 1 or croak "usage: new $class"; + my $fh = gensym; + bless $fh, $class; +} + +sub new_from_fd { + my $class = ref($_[0]) || $_[0] || "IO::Handle"; + @_ == 3 or croak "usage: new_from_fd $class FD, MODE"; + my $fh = gensym; + shift; + IO::Handle::fdopen($fh, @_) + or return undef; + bless $fh, $class; +} + +# +# There is no need for DESTROY to do anything, because when the +# last reference to an IO object is gone, Perl automatically +# closes its associated files (if any). However, to avoid any +# attempts to autoload DESTROY, we here define it to do nothing. +# +sub DESTROY {} + + +################################################ +## Open and close. +## + +sub _open_mode_string { + my ($mode) = @_; + $mode =~ /^\+?(<|>>?)$/ + or $mode =~ s/^r(\+?)$/$1/ + or $mode =~ s/^a(\+?)$/$1>>/ + or croak "IO::Handle: bad open mode: $mode"; + $mode; +} + +sub fdopen { + @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)'; + my ($fh, $fd, $mode) = @_; + local(*GLOB); + + if (ref($fd) && "".$fd =~ /GLOB\(/o) { + # It's a glob reference; Alias it as we cannot get name of anon GLOBs + my $n = qualify(*GLOB); + *GLOB = *{*$fd}; + $fd = $n; + } elsif ($fd =~ m#^\d+$#) { + # It's an FD number; prefix with "=". + $fd = "=$fd"; + } + + open($fh, _open_mode_string($mode) . '&' . $fd) + ? $fh : undef; +} + +sub close { + @_ == 1 or croak 'usage: $fh->close()'; + my($fh) = @_; + + close($fh); +} + +################################################ +## Normal I/O functions. +## + +# flock +# select + +sub opened { + @_ == 1 or croak 'usage: $fh->opened()'; + defined fileno($_[0]); +} + +sub fileno { + @_ == 1 or croak 'usage: $fh->fileno()'; + fileno($_[0]); +} + +sub getc { + @_ == 1 or croak 'usage: $fh->getc()'; + getc($_[0]); +} + +sub eof { + @_ == 1 or croak 'usage: $fh->eof()'; + eof($_[0]); +} + +sub print { + @_ or croak 'usage: $fh->print([ARGS])'; + my $this = shift; + print $this @_; +} + +sub printf { + @_ >= 2 or croak 'usage: $fh->printf(FMT,[ARGS])'; + my $this = shift; + printf $this @_; +} + +sub getline { + @_ == 1 or croak 'usage: $fh->getline'; + my $this = shift; + return scalar <$this>; +} + +*gets = \&getline; # deprecated + +sub getlines { + @_ == 1 or croak 'usage: $fh->getline()'; + wantarray or + croak 'Can\'t call $fh->getlines in a scalar context, use $fh->getline'; + my $this = shift; + return <$this>; +} + +sub truncate { + @_ == 2 or croak 'usage: $fh->truncate(LEN)'; + truncate($_[0], $_[1]); +} + +sub read { + @_ == 3 || @_ == 4 or croak '$fh->read(BUF, LEN [, OFFSET])'; + read($_[0], $_[1], $_[2], $_[3] || 0); +} + +sub sysread { + @_ == 3 || @_ == 4 or croak '$fh->sysread(BUF, LEN [, OFFSET])'; + sysread($_[0], $_[1], $_[2], $_[3] || 0); +} + +sub write { + @_ == 3 || @_ == 4 or croak '$fh->write(BUF, LEN [, OFFSET])'; + local($\) = ""; + print { $_[0] } substr($_[1], $_[3] || 0, $_[2]); +} + +sub syswrite { + @_ == 3 || @_ == 4 or croak '$fh->syswrite(BUF, LEN [, OFFSET])'; + syswrite($_[0], $_[1], $_[2], $_[3] || 0); +} + +sub stat { + @_ == 1 or croak 'usage: $fh->stat()'; + stat($_[0]); +} + +################################################ +## State modification functions. +## + +sub autoflush { + my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $|; + $| = @_ > 1 ? $_[1] : 1; + $prev; +} + +sub output_field_separator { + my $prev = $,; + $, = $_[1] if @_ > 1; + $prev; +} + +sub output_record_separator { + my $prev = $\; + $\ = $_[1] if @_ > 1; + $prev; +} + +sub input_record_separator { + my $prev = $/; + $/ = $_[1] if @_ > 1; + $prev; +} + +sub input_line_number { + # localizing $. doesn't work as advertised. grrrrrr. + my $prev = $.; + $. = $_[1] if @_ > 1; + $prev; +} + +sub format_page_number { + my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $%; + $% = $_[1] if @_ > 1; + $prev; +} + +sub format_lines_per_page { + my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $=; + $= = $_[1] if @_ > 1; + $prev; +} + +sub format_lines_left { + my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $-; + $- = $_[1] if @_ > 1; + $prev; +} + +sub format_name { + my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $~; + $~ = qualify($_[1], caller) if @_ > 1; + $prev; +} + +sub format_top_name { + my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $^; + $^ = qualify($_[1], caller) if @_ > 1; + $prev; +} + +sub format_line_break_characters { + my $prev = $:; + $: = $_[1] if @_ > 1; + $prev; +} + +sub format_formfeed { + my $prev = $^L; + $^L = $_[1] if @_ > 1; + $prev; +} + +sub formline { + my $fh = shift; + my $picture = shift; + local($^A) = $^A; + local($\) = ""; + formline($picture, @_); + print $fh $^A; +} + +sub format_write { + @_ < 3 || croak 'usage: $fh->write( [FORMAT_NAME] )'; + if (@_ == 2) { + my ($fh, $fmt) = @_; + my $oldfmt = $fh->format_name($fmt); + CORE::write($fh); + $fh->format_name($oldfmt); + } else { + CORE::write($_[0]); + } +} + +sub fcntl { + @_ == 3 || croak 'usage: $fh->fcntl( OP, VALUE );'; + my ($fh, $op, $val) = @_; + my $r = fcntl($fh, $op, $val); + defined $r && $r eq "0 but true" ? 0 : $r; +} + +sub ioctl { + @_ == 3 || croak 'usage: $fh->ioctl( OP, VALUE );'; + my ($fh, $op, $val) = @_; + my $r = ioctl($fh, $op, $val); + defined $r && $r eq "0 but true" ? 0 : $r; +} + +1; diff --git a/contrib/perl5/ext/IO/lib/IO/Pipe.pm b/contrib/perl5/ext/IO/lib/IO/Pipe.pm new file mode 100644 index 0000000..ae6d9a5 --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/Pipe.pm @@ -0,0 +1,239 @@ +# IO::Pipe.pm +# +# Copyright (c) 1996 Graham Barr . All rights +# reserved. This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Pipe; + +require 5.000; + +use IO::Handle; +use strict; +use vars qw($VERSION); +use Carp; +use Symbol; + +$VERSION = "1.0901"; + +sub new { + my $type = shift; + my $class = ref($type) || $type || "IO::Pipe"; + @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]"; + + my $me = bless gensym(), $class; + + my($readfh,$writefh) = @_ ? @_ : $me->handles; + + pipe($readfh, $writefh) + or return undef; + + @{*$me} = ($readfh, $writefh); + + $me; +} + +sub handles { + @_ == 1 or croak 'usage: $pipe->handles()'; + (IO::Pipe::End->new(), IO::Pipe::End->new()); +} + +my $do_spawn = $^O eq 'os2'; + +sub _doit { + my $me = shift; + my $rw = shift; + + my $pid = $do_spawn ? 0 : fork(); + + if($pid) { # Parent + return $pid; + } + elsif(defined $pid) { # Child or spawn + my $fh; + my $io = $rw ? \*STDIN : \*STDOUT; + my ($mode, $save) = $rw ? "r" : "w"; + if ($do_spawn) { + require Fcntl; + $save = IO::Handle->new_from_fd($io, $mode); + # Close in child: + fcntl(shift, Fcntl::F_SETFD(), 1) or croak "fcntl: $!"; + $fh = $rw ? ${*$me}[0] : ${*$me}[1]; + } else { + shift; + $fh = $rw ? $me->reader() : $me->writer(); # close the other end + } + bless $io, "IO::Handle"; + $io->fdopen($fh, $mode); + $fh->close; + + if ($do_spawn) { + $pid = eval { system 1, @_ }; # 1 == P_NOWAIT + my $err = $!; + + $io->fdopen($save, $mode); + $save->close or croak "Cannot close $!"; + croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0; + return $pid; + } else { + exec @_ or + croak "IO::Pipe: Cannot exec: $!"; + } + } + else { + croak "IO::Pipe: Cannot fork: $!"; + } + + # NOT Reached +} + +sub reader { + @_ >= 1 or croak 'usage: $pipe->reader()'; + my $me = shift; + my $fh = ${*$me}[0]; + my $pid = $me->_doit(0, $fh, @_) + if(@_); + + close ${*$me}[1]; + bless $me, ref($fh); + *{*$me} = *{*$fh}; # Alias self to handle + bless $fh; # Really wan't un-bless here + ${*$me}{'io_pipe_pid'} = $pid + if defined $pid; + + $me; +} + +sub writer { + @_ >= 1 or croak 'usage: $pipe->writer()'; + my $me = shift; + my $fh = ${*$me}[1]; + my $pid = $me->_doit(1, $fh, @_) + if(@_); + + close ${*$me}[0]; + bless $me, ref($fh); + *{*$me} = *{*$fh}; # Alias self to handle + bless $fh; # Really wan't un-bless here + ${*$me}{'io_pipe_pid'} = $pid + if defined $pid; + + $me; +} + +package IO::Pipe::End; + +use vars qw(@ISA); + +@ISA = qw(IO::Handle); + +sub close { + my $fh = shift; + my $r = $fh->SUPER::close(@_); + + waitpid(${*$fh}{'io_pipe_pid'},0) + if(defined ${*$fh}{'io_pipe_pid'}); + + $r; +} + +1; + +__END__ + +=head1 NAME + +IO::pipe - supply object methods for pipes + +=head1 SYNOPSIS + + use IO::Pipe; + + $pipe = new IO::Pipe; + + if($pid = fork()) { # Parent + $pipe->reader(); + + while(<$pipe> { + .... + } + + } + elsif(defined $pid) { # Child + $pipe->writer(); + + print $pipe .... + } + + or + + $pipe = new IO::Pipe; + + $pipe->reader(qw(ls -l)); + + while(<$pipe>) { + .... + } + +=head1 DESCRIPTION + +C provides an interface to createing pipes between +processes. + +=head1 CONSTRCUTOR + +=over 4 + +=item new ( [READER, WRITER] ) + +Creates a C, which is a reference to a newly created symbol +(see the C package). C optionally takes two +arguments, which should be objects blessed into C, or a +subclass thereof. These two objects will be used for the system call +to C. If no arguments are given then method C is called +on the new C object. + +These two handles are held in the array part of the GLOB until either +C or C is called. + +=back + +=head1 METHODS + +=over 4 + +=item reader ([ARGS]) + +The object is re-blessed into a sub-class of C, and becomes a +handle at the reading end of the pipe. If C are given then C +is called and C are passed to exec. + +=item writer ([ARGS]) + +The object is re-blessed into a sub-class of C, and becomes a +handle at the writing end of the pipe. If C are given then C +is called and C are passed to exec. + +=item handles () + +This method is called during construction by C +on the newly created C object. It returns an array of two objects +blessed into C, or a subclass thereof. + +=back + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Graham Barr + +=head1 COPYRIGHT + +Copyright (c) 1996 Graham Barr. All rights reserved. This program is free +software; you can redistribute it and/or modify it under the same terms +as Perl itself. + +=cut diff --git a/contrib/perl5/ext/IO/lib/IO/Seekable.pm b/contrib/perl5/ext/IO/lib/IO/Seekable.pm new file mode 100644 index 0000000..91c381a --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/Seekable.pm @@ -0,0 +1,68 @@ +# + +package IO::Seekable; + +=head1 NAME + +IO::Seekable - supply seek based methods for I/O objects + +=head1 SYNOPSIS + + use IO::Seekable; + package IO::Something; + @ISA = qw(IO::Seekable); + +=head1 DESCRIPTION + +C does not have a constuctor of its own as is intended to +be inherited by other C based objects. It provides methods +which allow seeking of the file descriptors. + +If the C functions fgetpos() and fsetpos() are available, then +C returns an opaque value that represents the +current position of the IO::File, and C uses +that value to return to a previously visited position. + +See L for complete descriptions of each of the following +supported C methods, which are just front ends for the +corresponding built-in functions: + + seek + tell + +=head1 SEE ALSO + +L, +L, +L +L + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr Ebodg@tiuk.ti.comE + +=cut + +require 5.000; +use Carp; +use strict; +use vars qw($VERSION @EXPORT @ISA); +use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); +require Exporter; + +@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END); +@ISA = qw(Exporter); + +$VERSION = "1.06"; + +sub seek { + @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)'; + seek($_[0], $_[1], $_[2]); +} + +sub tell { + @_ == 1 or croak 'usage: $fh->tell()'; + tell($_[0]); +} + +1; diff --git a/contrib/perl5/ext/IO/lib/IO/Select.pm b/contrib/perl5/ext/IO/lib/IO/Select.pm new file mode 100644 index 0000000..dea684a --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/Select.pm @@ -0,0 +1,371 @@ +# IO::Select.pm +# +# Copyright (c) 1995 Graham Barr. All rights reserved. This program is free +# software; you can redistribute it and/or modify it under the same terms +# as Perl itself. + +package IO::Select; + +=head1 NAME + +IO::Select - OO interface to the select system call + +=head1 SYNOPSIS + + use IO::Select; + + $s = IO::Select->new(); + + $s->add(\*STDIN); + $s->add($some_handle); + + @ready = $s->can_read($timeout); + + @ready = IO::Select->new(@handles)->read(0); + +=head1 DESCRIPTION + +The C package implements an object approach to the system C static method. + +=item bits() + +Return the bit string suitable as argument to the core select() call. + +=item bits() + +Return the bit string suitable as argument to the core select() call. + +=item select ( READ, WRITE, ERROR [, TIMEOUT ] ) + +C