--- Begin Message ---
|
Subject: |
Proper Lexical Pragma Modules |
|
Date: |
Tue, 02 Sep 2003 06:29:48 -0400 |
This core patch implements my idea for cheap lexical pragmas,
as I described in
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2002-04/msg02113.html
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2002-04/msg02119.html
This is to be considered a trial balloon, not a finished submission.
In no particular order:
0. The patch is against 5.9.0.
1. Writing pragmas with the new feature is very, very easy. I think
this is the Right Solution. See pragma/Demo.pm and pragma/t/1.t
for an example.
2. Most of the new code is in pp_ctl.c. This seems to me to be the
wrong place for it.
It's important for a Perl function to be able to test whether or
not a certain pragma was in scope at the place it was called. The
new C function I wrote for doing that is called 'firstpragma_n'.
Since pragmas are attached to COPs, firstpragma_n needs to look up
the context stack to find the COP in the calling fucntion. Perl
has a function for doing just that, called 'dopoptosub_at'.
'dopoptosub_at' is defined in pp_ctl.c and is static, so
'firstpragma_n' also had to be in pp_ctl.c.
a. Should I leave 'firstpragma_n' and its siblings in pp_ctl.c? Or
b. Should I make 'dopoptosub_at' not static? Or
c. Is there an alternative way to do it that I overlooked?
3. Access to this functionality is through a new standard module
called 'pragma' which provides functions for setting and examining
pragmas. A pragma can have arbitrary user-defined data associated
with it; the 'pragma' module demonstrates how to make pragmas where
this user data is a single SV.
4. It's easy to write an XS module that provides different access to
the core functionality, and I expect people will do this.
5. As noted above, given 'pragma', it's totally trivial to write an
all-Perl module that defines a new block-scoped pragma.
pragma::Demo is an example of how to do this.
6. I don't really know what I'm doing in the XS world, so I would be
grateful if people would look at what I've done for obvious
errors. Also this is my first time touching 'embed.fnc', so ditto.
7. I have NOT rerun Perl's test suite with this patch in place. It
might be a disaster.
8. I expect it might be a good idea to convert some of the existing
lexically scoped pragmata to use this interface, instead of
whatever they're doing now. I also expect it might be a good idea
to convert Hook::LexWrap, which claims to be lexically scoped, but
isn't. If it were to use this new 'pragma' feature, it could be
made lexically scoped.
9. The documentation is incomplete.
10. Eventually I would like to see runtime access to pragmas through a
special variable, perhaps %{^Pragmas}.
11. Not all of the functionality of the pragma feature is available
through the 'pragma' module. For example, given:
{
use mypragma 'on';
...
use mypragma 'off';
...
# is my pragma on or off here? # Line 377
}
The 'pragma' module will tell you that your pragma is off at line
377. But in
{
use somepragma 'enable-feature-A';
...
use somepragma 'enable-feature-B';
...
use somepragma 'disable-feature-A';
...
# which features of 'somepragma' are enabled here? # Line 377
}
The internal functions are sufficient to figure out that feature B
is enabled but feature A isn't, but you will need to write some XS
code to get at them; access to the necessary features isn't (yet)
provided by pragma.pm.
Best regards,
-D.
--- cop.h 2003/09/01 19:08:30 1.1
+++ cop.h 2003/09/01 21:43:40
@@ -13,6 +13,20 @@
* and thus can be used to determine our current state.
*/
+/* 20030901 address@hidden
+ * The pragma structure is a node in a linked list.
+ * The first two fields are always the same: a pointer to the next
+ * node in the list, and the name of the pragma.
+ * The structure may contain additional data whose type and format
+ * depends on the pragma name.
+ * Pragmas are a GLOBAL namespace, like modules.
+ */
+typedef struct st_pragma {
+ struct st_pragma *next;
+ char *name;
+} *PRAGMA;
+
+
struct cop {
BASEOP
char * cop_label; /* label for this construct */
@@ -28,6 +42,7 @@
line_t cop_line; /* line # of this command */
SV * cop_warnings; /* lexical warnings bitmask */
SV * cop_io; /* lexical IO defaults */
+ PRAGMA cop_pragmas; /* lexical pragmas defined for this line */
};
#define Nullcop Null(COP*)
--- op.c 2003/09/01 18:34:33 1.1
+++ op.c 2003/09/01 19:32:01
@@ -1757,6 +1757,7 @@
PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
SAVEFREESV(PL_compiling.cop_io) ;
}
+ SAVEPPTR(PL_compiling.cop_pragmas);
return retval;
}
@@ -3233,7 +3234,7 @@
cop->cop_io = PL_curcop->cop_io;
else
cop->cop_io = newSVsv(PL_curcop->cop_io) ;
-
+ cop->cop_pragmas = PL_curcop->cop_pragmas ;
if (PL_copline == NOLINE)
CopLINE_set(cop, CopLINE(PL_curcop));
--- pp_ctl.c 2003/09/02 09:54:30 1.1
+++ pp_ctl.c 2003/09/02 09:59:48
@@ -3841,3 +3841,62 @@
else
return FALSE;
}
+
+
+
+/*
+ * Lexical pragma utility routines for use by
+ * lexical pragma modules
+ *
+ * 20030802 address@hidden
+ */
+
+void install_pragma(PRAGMA pdata)
+{
+ /* invoked only at compile time */
+ pdata->next = PL_compiling.cop_pragmas;
+ PL_compiling.cop_pragmas = pdata;
+}
+
+PRAGMA nextpragma(char *name, PRAGMA start)
+{
+ /* invoked only at run time */
+ PRAGMA p;
+ if (*name == '\0') return start;
+
+ for (p = start; p; p = p->next)
+ if (strEQ(p->name, name))
+ return p;
+
+ return 0;
+}
+
+PRAGMA firstpragma_cop(char *name, COP *cop)
+{
+ /* invoked only at run time */
+ return nextpragma(name, cop->cop_pragmas);
+}
+
+PRAGMA firstpragma_n(char *name, int n)
+{
+ /* invoked only at run time */
+ register I32 cxix = dopoptosub(cxstack_ix);
+ register PERL_CONTEXT *cx;
+ COP * caller_cop;
+
+ n--;
+
+ while (n--)
+ cxix = dopoptosub_at(cxstack, cxix - 1);
+ cx = &cxstack[cxix];
+ caller_cop = cx->blk_oldcop;
+
+ return firstpragma_cop(name, caller_cop);
+}
+
+PRAGMA firstpragma(char *name)
+{
+ /* invoked only at run time */
+ return firstpragma_cop(name, PL_curcop);
+}
+
--- embed.fnc 2003/09/02 07:18:56 1.1
+++ embed.fnc 2003/09/02 08:51:56
@@ -1381,7 +1381,10 @@
pd |CV* |find_runcv |U32 *db_seqp
p |void |free_tied_hv_pool
-
-
END_EXTERN_C
+
+Ap |void |install_pragma |PRAGMA start
+Ap |PRAGMA |nextpragma |char *name |PRAGMA start
+Ap |PRAGMA |firstpragma |char *name
+Ap |PRAGMA |firstpragma_cop|char *name |COP *cop
--- /dev/null Fri Mar 23 23:37:44 2001
+++ ext/pragma/Makefile.PL Tue Sep 2 06:01:54 2003
@@ -0,0 +1,18 @@
+use 5.009;
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ 'NAME' => 'pragma',
+ 'VERSION_FROM' => 'pragma.pm', # finds $VERSION
+ 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1
+ ($] >= 5.005 ? ## Add these new keywords supported since 5.005
+ (
+# ABSTRACT_FROM => 'pragma.pm', # retrieve abstract from module
+ AUTHOR => 'Mark Jason Dominus <address@hidden>') : ()),
+# 'LIBS' => [''], # e.g., '-lm'
+ 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING'
+ 'INC' => '-I.', # e.g., '-I. -I/usr/include/other'
+ # Un-comment this if you add C files to link with later:
+ 'OBJECT' => '$(O_FILES)', # link all the C files too
+);
--- /dev/null Fri Mar 23 23:37:44 2001
+++ ext/pragma/README Tue Sep 2 03:13:13 2003
@@ -0,0 +1,38 @@
+Pragma version 0.01
+===================
+
+The README is used to introduce the module and provide instructions on
+how to install the module, any machine dependencies it may have (for
+example C compilers and installed libraries) and any other information
+that should be provided before the module is installed.
+
+A README file is required for CPAN modules since CPAN extracts the
+README file from a module distribution so that people browsing the
+archive can use it get an idea of the modules uses. It is usually a
+good idea to provide version information here so that people can
+decide whether fixes for the module are worth downloading.
+
+INSTALLATION
+
+To install this module type the following:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+DEPENDENCIES
+
+This module requires these other modules and libraries:
+
+ blah blah blah
+
+COPYRIGHT AND LICENCE
+
+Put the correct copyright and licence information here.
+
+Copyright (C) 2003 Mark Jason Dominus
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
--- /dev/null Fri Mar 23 23:37:44 2001
+++ ext/pragma/t/1.t Tue Sep 2 06:19:20 2003
@@ -0,0 +1,73 @@
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl 1.t'
+
+#########################
+
+# change 'tests => 1' to 'tests => last_test_to_print';
+
+use Test::More tests => 26;
+BEGIN {
+ use_ok('pragma::Demo');
+};
+
+sub bar {
+ is (current_pragma_value('pragma::Demo'), undef, "Scope is lexical, not
dynamic");
+}
+
+use pragma;
+
+use pragma::Demo 'x1';
+is (current_pragma_value('pragma::Demo'), '1', "Outer value is set");
+{
+ is (current_pragma_value('pragma::Demo'), '1', "Outer value is inherited");
+ use pragma::Demo 'x2';
+ is (current_pragma_value('pragma::Demo'), '2', "Inner value is set");
+ bar();
+}
+is (current_pragma_value('pragma::Demo'), '1', "Outer value is restored");
+use pragma::Demo 'x3';
+is (current_pragma_value('pragma::Demo'), '3', "Outer value is overidden");
+bar();
+
+{
+ is (current_pragma_value('pragma::Demo'), '3', "Outer value is inherited");
+ {
+ is (current_pragma_value('pragma::Demo'), '3', "Outer value is inherited");
+ use pragma::Demo 'x4';
+ is (current_pragma_value('pragma::Demo'), '4', "Inner value is
overridden");
+ bar();
+ }
+ is (current_pragma_value('pragma::Demo'), '3', "Inner value is restored");
+ use pragma::Demo 'x5';
+ is (current_pragma_value('pragma::Demo'), '5', "Inner value is overridden");
+ bar();
+}
+is (current_pragma_value('pragma::Demo'), '3', "Outer value is restored");
+is (current_pragma_value('SNONK'), undef, "Absent pragma is undef");
+bar();
+
+sub foo {
+ check_cpv(3);
+ use pragma::Demo 'x6';
+ check_cpv(6);
+ {
+ check_cpv(6);
+ use pragma::Demo 'x7';
+ check_cpv(7);
+ bar();
+ }
+ check_cpv(6);
+ use pragma::Demo 'x8';
+ check_cpv(8);
+ bar();
+}
+
+sub check_cpv {
+ my $expected = shift;
+ is (caller_pragma_value('pragma::Demo'), $expected,
+ "Caller pragma value $expected");
+}
+
+foo();
+
+
--- /dev/null Fri Mar 23 23:37:44 2001
+++ ext/pragma/pragma.pm Tue Sep 2 06:00:47 2003
@@ -0,0 +1,162 @@
+package pragma;
+
+use 5.008;
+use strict;
+use warnings;
+
+require Exporter;
+# use AutoLoader qw(AUTOLOAD);
+
+our @ISA = qw(Exporter);
+
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+
+# This allows declaration use Pragma3 ':all';
+# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
+# will save memory.
+our %EXPORT_TAGS = ( 'all' => [ qw(
+) ] );
+
+our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} }, );
+
+our @EXPORT = qw(
+install_pragma_value current_pragma_value
+ caller_pragma_value
+);
+
+our $VERSION = '0.01';
+
+require XSLoader;
+XSLoader::load('pragma', $VERSION);
+
+1;
+__END__
+
+=head1 NAME
+
+pragma - utility functions for lexically-scoped pragmas
+
+=head1 SYNOPSIS
+
+ package MyPragma;
+ use pragma;
+
+ sub import {
+ my ($class, $value) = @_;
+
+ # check $value here...
+
+ install_pragma_value($class, $value);
+ }
+
+ 1;
+
+=head1 ABSTRACT
+
+ This should be the abstract for pragma.
+ The abstract is used when making PPD (Perl Package Description) files.
+ If you don't want an ABSTRACT you should also edit Makefile.PL to
+ remove the ABSTRACT_FROM option.
+
+=head1 DESCRIPTION
+
+Every statement in a Perl program has a list of 'pragmas' associated
+with it. The pragmas are hints to modules or to the Perl interpreter
+that certain types of behavior should be changed. For example, a
+pragma might indicate to Perl that the C<strict 'vars'> checks should
+be performed for that statement.
+
+Each pragma has a name, which is a string, and perhaps some associated
+data. The data can be anything, but this module assumes that the data
+will be a regular Perl scalar (which, of course, could be a reference
+to a more complex data structure).
+
+Pragmas must be set at compile time. They can be looked up at run
+time. See L<perlpragma> for complete details about the internals of
+pragmas and the C interface to pragmas.
+
+Pragmatic modules may inherit the C<import> subroutine from the
+C<pragma> module itself, which performs the appropriate installation.
+If you want to define a pragma called C<mypragma>, create a
+C<mypragma.pm> file as indicated in the L<"SYNOPSIS"> section above.
+Then any other part of the program may use
+
+ {
+ ...
+ use mypragma "Carrots";
+ ...
+ }
+
+This declares that the pragma C<mypragma> is in scope to the end of
+the enclosing block. The name of the pragma is 'mypragma'; the value
+is C<"Carrots">. The value C<"Carrots"> will not be used by any
+module other than the C<mypragma> module.
+
+A more typical use of the pragma value would be:
+
+ {
+ ...
+ use mypragma "on";
+ ...
+ use mypragma "off";
+ ...
+ }
+
+Or perhaps:
+
+ {
+ ...
+ use strict 'vars';
+ ...
+ use strict 'refs', 'subs';
+ ...
+ }
+
+=head2 EXPORT
+
+=over 4
+
+=item C<install_pragma_value($name, $value)>
+
+This function associates a pragma with rest of the block that is
+presently being compiled. The scope of the pragma is from the
+statement currently being compiled to the end of the enclosing block.
+
+The C<$name> may be used to retrieve the specified C<$value>, which
+has no special meaning
+
+C<install_pragma_value> should be called at compile time, from within
+an C<import> subroutine. .
+
+=item C<current_pragma_value($name, $value)>
+
+Looks in the pragma list for the currently executing statement for the
+first pragma named C<$name>. If it finds one, it returns the
+corresponding C<$value>; otherwise, it returns C<undef>.
+
+=item C<caller_pragma_value($name, $value)>
+
+Like L<"current_pragma_value">, but for the currently executing
+statement in the calling function instead of the current function.
+
+=back
+
+
+=head1 SEE ALSO
+
+L<perlvar/"%^H">
+
+=head1 AUTHOR
+
+Mark Jason Dominus, E<lt>address@hidden<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2003 Mark Jason Dominus.
+
+This library is free software; you may redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null Fri Mar 23 23:37:44 2001
+++ ext/pragma/pragma.xs Tue Sep 2 05:59:51 2003
@@ -0,0 +1,62 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include "ppport.h"
+
+typedef struct Pragma_SV_pragma {
+ PRAGMA next;
+ char *name;
+ SV *sv;
+} *Pragma_SV_PRAGMA;
+
+
+MODULE = pragma PACKAGE = pragma
+
+
+IV install_pragma_value(name, sv)
+ char *name;
+ SV *sv;
+ CODE:
+ {
+
+ Pragma_SV_PRAGMA p;
+
+ New(119, p, 1, struct Pragma_SV_pragma);
+ p->sv = newSVsv(sv);
+ p->name = name;
+ install_pragma((PRAGMA) p);
+ RETVAL = 1;
+ }
+ OUTPUT:
+ RETVAL
+
+SV*
+current_pragma_value(name)
+ char *name;
+ CODE:
+ {
+ Pragma_SV_PRAGMA p =
+ (Pragma_SV_PRAGMA) firstpragma(name);
+ if (p == 0 || p->sv == 0)
+ RETVAL = &PL_sv_undef;
+ else
+ RETVAL = newSVsv(p->sv);
+ }
+ OUTPUT:
+ RETVAL
+
+SV*
+caller_pragma_value(name)
+ char *name;
+ CODE:
+ {
+ Pragma_SV_PRAGMA p =
+ (Pragma_SV_PRAGMA) firstpragma_n(name, 1);
+ if (p == 0 || p->sv == 0)
+ RETVAL = &PL_sv_undef;
+ else
+ RETVAL = newSVsv(p->sv);
+ }
+ OUTPUT:
+ RETVAL
--- /dev/null Fri Mar 23 23:37:44 2001
+++ ext/pragma/Demo/Makefile.PL Tue Sep 2 04:31:29 2003
@@ -0,0 +1,11 @@
+use 5.009;
+use strict;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ INC => "-I../pragma",
+ NAME => 'pragma::Demo',
+ VERSION_FROM => "Demo.pm",
+ MAN3PODS => {},
+ );
+
--- /dev/null Fri Mar 23 23:37:44 2001
+++ ext/pragma/Demo/Demo.pm Tue Sep 2 05:25:37 2003
@@ -0,0 +1,15 @@
+
+package pragma::Demo;
+use pragma;
+
+our $VERSION = 0.01;
+
+sub import {
+ my ($class, $arg) = @_;
+ $arg ||= 0;
+ $arg =~ tr/0-9//cd;
+# warn "pragma::Demo::import($arg)\n";
+ install_pragma_value($class, $arg);
+}
+
+1;
--- End Message ---