From: Matthijs van Duin Date: Wed, 18 Aug 2004 13:35:08 +0000 (-0800) Subject: initial import of Sub-Name 0.01 from CPAN X-Git-Tag: 0.01 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=16c238946dc5ef5a2ddc13ebc0b57f3a0629f03e;p=p5sagit%2FSub-Name.git initial import of Sub-Name 0.01 from CPAN git-cpan-module: Sub-Name git-cpan-version: 0.01 git-cpan-authorid: XMATH git-cpan-file: authors/id/X/XM/XMATH/Sub-Name-0.01.tar.gz --- 16c238946dc5ef5a2ddc13ebc0b57f3a0629f03e diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..75b2378 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,7 @@ +MANIFEST +META.yml +Makefile.PL +Name.xs +README +lib/Sub/Name.pm +t/smoke.t diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..c961a7d --- /dev/null +++ b/META.yml @@ -0,0 +1,10 @@ +# http://module-build.sourceforge.net/META-spec.html +#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# +name: Sub-Name +version: 0.01 +version_from: lib/Sub/Name.pm +installdirs: site +requires: + +distribution_type: module +generated_by: ExtUtils::MakeMaker version 6.17 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..5c8a75f --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,11 @@ +# $Id: Makefile.PL,v 1.1 2004/08/17 19:23:24 xmath Exp $ + +use 5.006; +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Sub::Name', + VERSION_FROM => 'lib/Sub/Name.pm', + ABSTRACT_FROM => 'lib/Sub/Name.pm', + AUTHOR => 'Matthijs van Duin ' +); diff --git a/Name.xs b/Name.xs new file mode 100644 index 0000000..a338c3c --- /dev/null +++ b/Name.xs @@ -0,0 +1,63 @@ +/* $Id: Name.xs,v 1.5 2004/08/18 13:21:44 xmath Exp $ + * Copyright (C) 2004 Matthijs van Duin. All rights reserved. + * This program is free software; you can redistribute it and/or modify + * it under the same terms as Perl itself. + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifdef USE_5005THREADS +#error "Not compatible with 5.005 threads" +#endif + +MODULE = Sub::Name PACKAGE = Sub::Name + +PROTOTYPES: DISABLE + +void +subname(name, sub) + char *name + SV *sub + PREINIT: + CV *cv = NULL; + GV *gv; + HV *stash = CopSTASH(PL_curcop); + char *s, *end = NULL, saved; + PPCODE: + if (!SvROK(sub) && SvGMAGICAL(sub)) + mg_get(sub); + if (SvROK(sub)) + cv = (CV *) SvRV(sub); + else if (SvTYPE(sub) == SVt_PVGV) + cv = GvCVu(sub); + else if (!SvOK(sub)) + croak(PL_no_usym, "a subroutine"); + else if (PL_op->op_private & HINT_STRICT_REFS) + croak(PL_no_symref, SvPV_nolen(sub), "a subroutine"); + else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV))) + cv = GvCVu(gv); + if (!cv) + croak("Undefined subroutine %s", SvPV_nolen(sub)); + if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM) + croak("Not a subroutine reference"); + for (s = name; *s++; ) { + if (*s == ':' && s[-1] == ':') + end = ++s; + else if (*s && s[-1] == '\'') + end = s; + } + s--; + if (end) { + saved = *end; + *end = 0; + stash = GvHV(gv_fetchpv(name, TRUE, SVt_PVHV)); + *end = saved; + name = end; + } + gv = (GV *) newSV(0); + gv_init(gv, stash, name, s - name, TRUE); + av_store((AV *) AvARRAY(CvPADLIST(cv))[0], 0, (SV *) gv); + CvGV(cv) = gv; + PUSHs(sub); diff --git a/README b/README new file mode 100644 index 0000000..3bf1a28 --- /dev/null +++ b/README @@ -0,0 +1,48 @@ +$Id: README,v 1.4 2004/08/18 12:03:42 xmath Exp $ + +Sub::Name 0.01 + +To install this module type the following: + + perl Makefile.PL + make + make test + make install + + +Module documentation: + +NAME + Sub::Name - (re)name a sub + +SYNOPSIS + use Sub::Name; + + subname $name, $subref; + + $subref = subname foo => sub { ... }; + +DESCRIPTION + This module has two functions to assign a new name to a sub -- in + particular an anonymous sub -- which is displayed in tracebacks and + such. Both functions are exported by default. + + subname NAME, CODEREF + Assigns a new name to referenced sub. If package specification is + omitted in the name, then the current package is used. The return value + is the sub. + + The name is only used for informative routines (caller, Carp, etc). You + won't be able to actually invoke the sub by the given name. To allow + that, you need to do glob-assignment yourself. + + Note that for closures (anonymous subs that reference lexicals outside + the sub itself) you can name each instance of the closure differently, + which can be very useful for debugging. + +AUTHOR + Matthijs van Duin + + Copyright (C) 2004 Matthijs van Duin. All rights reserved. This program + is free software; you can redistribute it and/or modify it under the + same terms as Perl itself. diff --git a/lib/Sub/Name.pm b/lib/Sub/Name.pm new file mode 100644 index 0000000..c881b39 --- /dev/null +++ b/lib/Sub/Name.pm @@ -0,0 +1,61 @@ +# $Id: Name.pm,v 1.4 2004/08/18 12:03:42 xmath Exp $ + +package Sub::Name; + +=head1 NAME + +Sub::Name - (re)name a sub + +=head1 SYNOPSIS + + use Sub::Name; + + subname $name, $subref; + + $subref = subname foo => sub { ... }; + +=head1 DESCRIPTION + +This module has two functions to assign a new name to a sub -- in particular an +anonymous sub -- which is displayed in tracebacks and such. Both functions are +exported by default. + +=head2 subname NAME, CODEREF + +Assigns a new name to referenced sub. If package specification is omitted in +the name, then the current package is used. The return value is the sub. + +The name is only used for informative routines (caller, Carp, etc). You won't +be able to actually invoke the sub by the given name. To allow that, you need +to do glob-assignment yourself. + +Note that for closures (anonymous subs that reference lexicals outside the sub +itself) you can name each instance of the closure differently, which can be +very useful for debugging. + +=head1 AUTHOR + +Matthijs van Duin + +Copyright (C) 2004 Matthijs van Duin. All rights reserved. +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +use 5.006; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use base 'Exporter'; +use base 'DynaLoader'; + +our @EXPORT = qw(subname); +our @EXPORT_OK = @EXPORT; + +bootstrap Sub::Name $VERSION; + +1; diff --git a/t/smoke.t b/t/smoke.t new file mode 100644 index 0000000..5c13ecc --- /dev/null +++ b/t/smoke.t @@ -0,0 +1,24 @@ +#!/usr/bin/perl + +BEGIN { print "1..3\n"; } + + +use Sub::Name; + +my $x = subname foo => sub { (caller 0)[3] }; +print $x->() eq "main::foo" ? "ok 1\n" : "not ok 1\n"; + + +package Blork; + +use Sub::Name; + +subname " Bar!", $x; +print $x->() eq "Blork:: Bar!" ? "ok 2\n" : "not ok 2\n"; + +subname "Foo::Bar::Baz", $x; +print $x->() eq "Foo::Bar::Baz" ? "ok 3\n" : "not ok 3\n"; + + +# $Id: smoke.t,v 1.4 2004/08/18 12:03:42 xmath Exp $ +# vim: ft=perl