Commit 02075e6542d965001346c1285472c6029ab7dd6d - libkeyword-simple-perl

New upstream version 0.04 Salvatore Bonaccorso 6 years ago

15 changed file(s) with 583 addition(s) and 316 deletion(s). Raw diff Collapse all Expand all

-0

Changes less more

0	0	Revision history for Keyword-Simple
	1
	2	0.04 2017-09-08
	3	- Fix crash when using keywords in string eval (RT #122983).
	4	- Document that keywords are broken in s//.../e.
1	5
2	6	0.03 2014-10-19
3	7	- Add note to POD about requiring perl v5.12.

-4

MANIFEST less more

0	0	Changes
	1	lib/Keyword/Simple.pm
	2	Makefile.PL
	3	Makefile_PL_settings.plx
1	4	MANIFEST
2	5	MANIFEST.SKIP
3		Makefile.PL
4		README
5	6	Simple.xs
6		lib/Keyword/Simple.pm
7	7	t/00-load.t
8	8	t/basic.t
	9	t/eval.t
9	10	t/lineno.t
10		t/pod.t
	11	xt/pod.t
11	12	META.yml Module YAML meta-data (added by MakeMaker)
12	13	META.json Module JSON meta-data (added by MakeMaker)
	14	README generated from Keyword::Simple POD (added by maint/eumm-fixup.pl)

-1

MANIFEST.SKIP less more

0	0	\.tar\.gz$
1	1	^Build$
2	2	^Keyword-Simple-
3		^GNUmakefile$
4	3	^MANIFEST\.(?!SKIP$)
5	4	^MYMETA\.
6	5	^Makefile$

13	12	^pm_to_blib
14	13	^remote$
15	14	^untracked
	15	^maint/

+17

-8

META.json less more

2	2	"author" : [
3	3	"Lukas Mai <l.mai@web.de>"
4	4	],
5		"dynamic_config" : 1,
6		"generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.140640",
	5	"dynamic_config" : 0,
	6	"generated_by" : "ExtUtils::MakeMaker version 7.3, CPAN::Meta::Converter version 2.150010",
7	7	"license" : [
8	8	"perl_5"
9	9	],
10	10	"meta-spec" : {
11	11	"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
12		"version" : "2"
	12	"version" : 2
13	13	},
14	14	"name" : "Keyword-Simple",
15	15	"no_index" : {
16	16	"directory" : [
17	17	"t",
18		"inc"
	18	"inc",
	19	"xt"
19	20	]
20	21	},
21	22	"prereqs" : {

24	25	},
25	26	"configure" : {
26	27	"requires" : {
27		"ExtUtils::MakeMaker" : "6.48",
	28	"ExtUtils::MakeMaker" : "0",
	29	"File::Find" : "0",
	30	"File::Spec" : "0",
28	31	"strict" : "0",
29	32	"warnings" : "0"
30	33	}
31	34	},
	35	"develop" : {
	36	"requires" : {
	37	"Pod::Markdown" : "3.005",
	38	"Pod::Text" : "4.09",
	39	"Test::Pod" : "1.22"
	40	}
	41	},
32	42	"runtime" : {
33	43	"requires" : {
34		"B::Hooks::EndOfScope" : "0",
35	44	"Carp" : "0",
36	45	"XSLoader" : "0",
37	46	"perl" : "5.012000",

40	49	},
41	50	"test" : {
42	51	"requires" : {
43		"Dir::Self" : "0",
44	52	"Test::More" : "0",
45	53	"strict" : "0"
46	54	}

54	62	"web" : "https://github.com/mauke/Keyword-Simple"
55	63	}
56	64	},
57		"version" : "0.03"
	65	"version" : "0.04",
	66	"x_serialization_backend" : "JSON::PP version 2.94"
58	67	}

-6

META.yml less more

2	2	author:
3	3	- 'Lukas Mai <l.mai@web.de>'
4	4	build_requires:
5		Dir::Self: '0'
6	5	Test::More: '0'
7	6	strict: '0'
8	7	configure_requires:
9		ExtUtils::MakeMaker: '6.48'
	8	ExtUtils::MakeMaker: '0'
	9	File::Find: '0'
	10	File::Spec: '0'
10	11	strict: '0'
11	12	warnings: '0'
12		dynamic_config: 1
13		generated_by: 'ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.140640'
	13	dynamic_config: 0
	14	generated_by: 'ExtUtils::MakeMaker version 7.3, CPAN::Meta::Converter version 2.150010'
14	15	license: perl
15	16	meta-spec:
16	17	url: http://module-build.sourceforge.net/META-spec-v1.4.html

20	21	directory:
21	22	- t
22	23	- inc
	24	- xt
23	25	requires:
24		B::Hooks::EndOfScope: '0'
25	26	Carp: '0'
26	27	XSLoader: '0'
27	28	perl: '5.012000'
28	29	warnings: '0'
29	30	resources:
30	31	repository: git://github.com/mauke/Keyword-Simple
31		version: '0.03'
	32	version: '0.04'
	33	x_serialization_backend: 'CPAN::Meta::YAML version 0.018'

+130

-54

Makefile.PL less more

0	0	use strict;
1	1	use warnings;
2	2	use ExtUtils::MakeMaker;
	3	use File::Spec ();
	4	use File::Find ();
3	5
4		sub merge_key_into {
5		my ($href, $target, $source) = @_;
6		%{$href->{$target}} = (%{$href->{$target}}, %{delete $href->{$source}});
	6	sub find_tests_recursively_in {
	7	my ($dir) = @_;
	8	-d $dir or die "$dir is not a directory";
	9
	10	my %seen;
	11	my $wanted = sub {
	12	/\.t\z/ or return;
	13	my $directories = (File::Spec->splitpath($File::Find::name))[1];
	14	my $depth = grep $_ ne '', File::Spec->splitdir($directories);
	15	$seen{$depth} = 1;
	16	};
	17	File::Find::find($wanted, $dir);
	18
	19	join ' ',
	20	map { $dir . '/*' x $_ . '.t' }
	21	sort { $a <=> $b }
	22	keys %seen
7	23	}
8	24
9		my %opt = (
10		NAME => 'Keyword::Simple',
11		AUTHOR => q{Lukas Mai <l.mai@web.de>},
12		VERSION_FROM => 'lib/Keyword/Simple.pm',
13		ABSTRACT_FROM => 'lib/Keyword/Simple.pm',
	25	$::MAINT_MODE = !-f 'META.yml';
	26	my $settings_file = 'Makefile_PL_settings.plx';
	27	my %settings = %{do "./$settings_file" or die "Internal error: can't do $settings_file: ", $@ \|\| $!};
14	28
15		LICENSE => 'perl',
16		PL_FILES => {},
	29	{
	30	$settings{depend}{Makefile} .= " $settings_file";
	31	$settings{LICENSE} \|\|= 'perl';
	32	$settings{PL_FILES} \|\|= {};
17	33
18		MIN_PERL_VERSION => '5.12.0',
19		CONFIGURE_REQUIRES => {
20		'strict' => 0,
21		'warnings' => 0,
22		'ExtUtils::MakeMaker' => '6.48',
23		},
24		BUILD_REQUIRES => {},
25		TEST_REQUIRES => {
26		'strict' => 0,
27		'Dir::Self' => 0,
28		'Test::More' => 0,
29		},
30		PREREQ_PM => {
31		'Carp' => 0,
32		'XSLoader' => 0,
33		'warnings' => 0,
34		'B::Hooks::EndOfScope' => 0,
35		},
	34	$settings{CONFIGURE_REQUIRES}{strict} \|\|= 0;
	35	$settings{CONFIGURE_REQUIRES}{warnings} \|\|= 0;
	36	$settings{CONFIGURE_REQUIRES}{'ExtUtils::MakeMaker'} \|\|= 0;
	37	$settings{CONFIGURE_REQUIRES}{'File::Find'} \|\|= 0;
	38	$settings{CONFIGURE_REQUIRES}{'File::Spec'} \|\|= 0;
36	39
37		depend => { Makefile => '$(VERSION_FROM)' },
38		dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
39		clean => { FILES => 'Keyword-Simple-*' },
	40	my $module_file = $settings{NAME};
	41	$module_file =~ s!::!/!g;
	42	$module_file = "lib/$module_file.pm";
40	43
41		META_MERGE => {
42		'meta-spec' => { version => 2 },
43		resources => {
44		repository => {
45		url => 'git://github.com/mauke/Keyword-Simple',
46		web => 'https://github.com/mauke/Keyword-Simple',
47		type => 'git',
48		},
49		},
50		},
51		);
	44	$settings{VERSION_FROM} \|\|= $module_file;
	45	$settings{ABSTRACT_FROM} \|\|= $module_file;
52	46
53		(my $mm_version = ExtUtils::MakeMaker->VERSION($opt{CONFIGURE_REQUIRES}{'ExtUtils::MakeMaker'})) =~ tr/_//d;
	47	$settings{test}{TESTS} \|\|= find_tests_recursively_in 't';
54	48
55		if ($mm_version < 6.67_04) {
56		# Why? For the glory of satan, of course!
57		no warnings qw(redefine);
58		*ExtUtils::MM_Any::_add_requirements_to_meta_v1_4 = \&ExtUtils::MM_Any::_add_requirements_to_meta_v2;
	49	$settings{DISTNAME} \|\|= do {
	50	my $name = $settings{NAME};
	51	$name =~ s!::!-!g;
	52	$name
	53	};
	54
	55	$settings{clean}{FILES} \|\|= "$settings{DISTNAME}-*";
	56
	57	$settings{dist}{COMPRESS} \|\|= 'gzip -9f';
	58	$settings{dist}{SUFFIX} \|\|= '.gz';
	59
	60	my $version = $settings{VERSION} \|\| MM->parse_version($settings{VERSION_FROM});
	61	if ($version =~ s/-TRIAL[0-9]*\z//) {
	62	$settings{META_MERGE}{release_status} \|\|= 'unstable';
	63	$settings{META_MERGE}{version} \|\|= $version;
	64	$settings{XS_VERSION} \|\|= $version;
	65	}
	66
	67	$settings{META_MERGE}{'meta-spec'}{version} \|\|= 2;
	68	$settings{META_MERGE}{dynamic_config} \|\|= 0;
	69
	70	push @{$settings{META_MERGE}{no_index}{directory}}, 'xt';
	71	if (my $dev = delete $settings{DEVELOP_REQUIRES}) {
	72	@{$settings{META_MERGE}{prereqs}{develop}{requires}}{keys %$dev} = values %$dev;
	73	}
	74	if (my $rec = delete $settings{RECOMMENDS}) {
	75	@{$settings{META_MERGE}{prereqs}{runtime}{recommends}}{keys %$rec} = values %$rec;
	76	}
	77
	78	if (my $sug = delete $settings{SUGGESTS}) {
	79	@{$settings{META_MERGE}{prereqs}{runtime}{suggests}}{keys %$sug} = values %$sug;
	80	}
	81
	82	if (my $repo = delete $settings{REPOSITORY}) {
	83	if (ref($repo) eq 'ARRAY') {
	84	my ($type, @args) = @$repo;
	85	if ($type eq 'github') {
	86	my ($account, $project) = @args;
	87	$project \|\|= '%d';
	88	$project =~ s{%(L?)(.)}{
	89	my $x =
	90	$2 eq '%' ? '%' :
	91	$2 eq 'd' ? $settings{DISTNAME} :
	92	$2 eq 'm' ? $settings{NAME} :
	93	die "Internal error: unknown placeholder %$1$2";
	94	$1 ? lc($x) : $x
	95	}seg;
	96	my $addr = "github.com/$account/$project";
	97	$repo = {
	98	type => 'git',
	99	url => "git://$addr",
	100	web => "https://$addr",
	101	};
	102	} else {
	103	die "Internal error: unknown REPOSITORY type '$type'";
	104	}
	105	}
	106	ref($repo) eq 'HASH' or die "Internal error: REPOSITORY must be a hashref, not $repo";
	107	@{$settings{META_MERGE}{resources}{repository}}{keys %$repo} = values %$repo;
	108	}
59	109	}
60	110
	111	(do './maint/eumm-fixup.pl' \|\| die $@ \|\| $!)->(\%settings) if $::MAINT_MODE;
	112
	113	(my $mm_version = ExtUtils::MakeMaker->VERSION) =~ tr/_//d;
	114
61	115	if ($mm_version < 6.63_03) {
62		merge_key_into \%opt, 'BUILD_REQUIRES', 'TEST_REQUIRES';
	116	$settings{META_MERGE}{resources}{repository} = $settings{META_MERGE}{resources}{repository}{url}
	117	if $settings{META_MERGE}{resources} &&
	118	$settings{META_MERGE}{resources}{repository} &&
	119	$settings{META_MERGE}{resources}{repository}{url};
	120	delete $settings{META_MERGE}{'meta-spec'}{version};
	121	} elsif ($mm_version < 6.67_04) {
	122	# Why? For the glory of satan, of course!
	123	no warnings qw(redefine);
	124	*ExtUtils::MM_Any::_add_requirements_to_meta_v1_4 = \&ExtUtils::MM_Any::_add_requirements_to_meta_v2;
63	125	}
64	126
65		if ($mm_version < 6.55_01) {
66		merge_key_into \%opt, 'CONFIGURE_REQUIRES', 'BUILD_REQUIRES';
	127	{
	128	my $merge_key_into = sub {
	129	my ($target, $source) = @_;
	130	%{$settings{$target}} = (%{$settings{$target}}, %{delete $settings{$source}});
	131	};
	132
	133	$merge_key_into->('BUILD_REQUIRES', 'TEST_REQUIRES')
	134	if $mm_version < 6.63_03;
	135
	136	$merge_key_into->('CONFIGURE_REQUIRES', 'BUILD_REQUIRES')
	137	if $mm_version < 6.55_01;
	138
	139	$merge_key_into->('PREREQ_PM', 'CONFIGURE_REQUIRES')
	140	if $mm_version < 6.51_03;
67	141	}
68	142
69		if ($mm_version < 6.51_03) {
70		merge_key_into \%opt, 'PREREQ_PM', 'CONFIGURE_REQUIRES';
71		}
	143	delete $settings{MIN_PERL_VERSION} if $mm_version < 6.47_01;
	144	delete $settings{META_MERGE} if $mm_version < 6.46;
	145	delete $settings{LICENSE} if $mm_version < 6.30_01;
	146	delete $settings{ABSTRACT_FROM} if $mm_version < 6.06_03;
	147	delete $settings{AUTHOR} if $mm_version < 6.06_03;
72	148
73		WriteMakefile %opt;
	149	WriteMakefile %settings;

+27

-0

Makefile_PL_settings.plx less more

	0	use strict;
	1	use warnings;
	2
	3	return {
	4	NAME => 'Keyword::Simple',
	5	AUTHOR => q{Lukas Mai <l.mai@web.de>},
	6
	7	MIN_PERL_VERSION => '5.12.0',
	8	CONFIGURE_REQUIRES => {},
	9	BUILD_REQUIRES => {},
	10	TEST_REQUIRES => {
	11	'strict' => 0,
	12	'Test::More' => 0,
	13	},
	14	PREREQ_PM => {
	15	'Carp' => 0,
	16	'XSLoader' => 0,
	17	'warnings' => 0,
	18	},
	19	DEVELOP_REQUIRES => {
	20	'Test::Pod' => 1.22,
	21	},
	22
	23	depend => { Makefile => '$(VERSION_FROM)' },
	24
	25	REPOSITORY => [ github => 'mauke' ],
	26	};

+32

-29

README less more

0		Keyword-Simple
	0	NAME
1	1
2		define new keywords in pure Perl
3
	2	Keyword::Simple - define new keywords in pure Perl
4	3
5	4	INSTALLATION
6	5
7		To install this module, run the following commands:
	6	To download and install this module, use your favorite CPAN client, e.g.
	7	"cpan":
8	8
9		perl Makefile.PL
10		make
11		make test
12		make install
	9	cpan Keyword::Simple
	10
	11	Or "cpanm":
	12
	13	cpanm Keyword::Simple
	14
	15	To do it manually, run the following commands (after downloading and
	16	unpacking the tarball):
	17
	18	perl Makefile.PL
	19	make
	20	make test
	21	make install
13	22
14	23	SUPPORT AND DOCUMENTATION
15	24
16		After installing, you can find documentation for this module with the
17		perldoc command.
	25	After installing, you can find documentation for this module with the
	26	"perldoc" command.
18	27
19		perldoc Keyword::Simple
	28	perldoc Keyword::Simple
20	29
21		You can also look for information at:
	30	You can also look for information at
	31	<https://metacpan.org/pod/Keyword::Simple>.
22	32
23		RT, CPAN's request tracker
24		http://rt.cpan.org/NoAuth/Bugs.html?Dist=Keyword-Simple
	33	To see a list of open bugs, visit
	34	<https://rt.cpan.org/Public/Dist/Display.html?Name=Keyword-Simple>.
25	35
26		AnnoCPAN, Annotated CPAN documentation
27		http://annocpan.org/dist/Keyword-Simple
	36	To report a new bug, send an email to "bug-Keyword-Simple [at]
	37	rt.cpan.org".
28	38
29		CPAN Ratings
30		http://cpanratings.perl.org/d/Keyword-Simple
	39	COPYRIGHT & LICENSE
31	40
32		MetaCPAN
33		https://metacpan.org/module/Keyword::Simple
	41	Copyright (C) 2012, 2013 Lukas Mai.
34	42
	43	This program is free software; you can redistribute it and/or modify it
	44	under the terms of either: the GNU General Public License as published
	45	by the Free Software Foundation; or the Artistic License.
35	46
36		COPYRIGHT AND LICENCE
	47	See http://dev.perl.org/licenses/ for more information.
37	48
38		Copyright (C) 2012, 2013 Lukas Mai
39
40		This program is free software; you can redistribute it and/or modify it
41		under the terms of either: the GNU General Public License as published
42		by the Free Software Foundation; or the Artistic License.
43
44		See http://dev.perl.org/licenses/ for more information.
45

+204

-153

Simple.xs less more

0	0	/*
1		Copyright 2012, 2013 Lukas Mai.
	1	Copyright 2012, 2013, 2017 Lukas Mai.
2	2
3	3	This program is free software; you can redistribute it and/or modify it
4	4	under the terms of either: the GNU General Public License as published

8	8	*/
9	9
10	10	#ifdef __GNUC__
	11	#if __GNUC__ >= 5
	12	#define IF_HAVE_GCC_5(X) X
	13	#endif
	14
11	15	#if (__GNUC__ == 4 && __GNUC_MINOR__ >= 6) \|\| __GNUC__ >= 5
12	16	#define PRAGMA_GCC_(X) _Pragma(#X)
13	17	#define PRAGMA_GCC(X) PRAGMA_GCC_(GCC X)
14	18	#endif
15	19	#endif
16	20
	21	#ifndef IF_HAVE_GCC_5
	22	#define IF_HAVE_GCC_5(X)
	23	#endif
	24
17	25	#ifndef PRAGMA_GCC
18	26	#define PRAGMA_GCC(X)
19	27	#endif
20	28
21	29	#ifdef DEVEL
22	30	#define WARNINGS_RESET PRAGMA_GCC(diagnostic pop)
23		#define WARNINGS_ENABLEW(X) PRAGMA_GCC(diagnostic warning #X)
	31	#define WARNINGS_ENABLEW(X) PRAGMA_GCC(diagnostic error #X)
24	32	#define WARNINGS_ENABLE \
25		WARNINGS_ENABLEW(-Wall) \
26		WARNINGS_ENABLEW(-Wextra) \
27		WARNINGS_ENABLEW(-Wundef) \
28		/* WARNINGS_ENABLEW(-Wshadow) :-( */ \
29		WARNINGS_ENABLEW(-Wbad-function-cast) \
30		WARNINGS_ENABLEW(-Wcast-align) \
31		WARNINGS_ENABLEW(-Wwrite-strings) \
32		/* WARNINGS_ENABLEW(-Wnested-externs) wtf? */ \
33		WARNINGS_ENABLEW(-Wstrict-prototypes) \
34		WARNINGS_ENABLEW(-Wmissing-prototypes) \
35		WARNINGS_ENABLEW(-Winline) \
36		WARNINGS_ENABLEW(-Wdisabled-optimization)
	33	WARNINGS_ENABLEW(-Wall) \
	34	WARNINGS_ENABLEW(-Wextra) \
	35	WARNINGS_ENABLEW(-Wundef) \
	36	WARNINGS_ENABLEW(-Wshadow) \
	37	WARNINGS_ENABLEW(-Wbad-function-cast) \
	38	WARNINGS_ENABLEW(-Wcast-align) \
	39	WARNINGS_ENABLEW(-Wwrite-strings) \
	40	WARNINGS_ENABLEW(-Wstrict-prototypes) \
	41	WARNINGS_ENABLEW(-Wmissing-prototypes) \
	42	WARNINGS_ENABLEW(-Winline) \
	43	WARNINGS_ENABLEW(-Wdisabled-optimization) \
	44	IF_HAVE_GCC_5(WARNINGS_ENABLEW(-Wnested-externs))
37	45
38	46	#else
39	47	#define WARNINGS_RESET

47	55	#include "XSUB.h"
48	56
49	57	#include <string.h>
	58	#include <stdlib.h>
	59
	60	#ifdef DEVEL
	61	#undef NDEBUG
	62	#endif
50	63	#include <assert.h>
51		#include <stdlib.h>
52
	64
	65	#define HAVE_PERL_VERSION(R, V, S) \
	66	(PERL_REVISION > (R) \|\| (PERL_REVISION == (R) && (PERL_VERSION > (V) \|\| (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
	67
	68	#ifndef STATIC_ASSERT_STMT
	69	#if (defined(static_assert) \|\| (defined(__cplusplus) && __cplusplus >= 201103L)) && (!defined(__IBMC__) \|\| __IBMC__ >= 1210)
	70	/* static_assert is a macro defined in <assert.h> in C11 or a compiler
	71	builtin in C++11. But IBM XL C V11 does not support _Static_assert, no
	72	matter what <assert.h> says.
	73	*/
	74	# define STATIC_ASSERT_DECL(COND) static_assert(COND, #COND)
	75	#else
	76	/* We use a bit-field instead of an array because gcc accepts
	77	'typedef char x[n]' where n is not a compile-time constant.
	78	We want to enforce constantness.
	79	*/
	80	# define STATIC_ASSERT_2(COND, SUFFIX) \
	81	typedef struct { \
	82	unsigned int _static_assertion_failed_##SUFFIX : (COND) ? 1 : -1; \
	83	} _static_assertion_failed_##SUFFIX PERL_UNUSED_DECL
	84	# define STATIC_ASSERT_1(COND, SUFFIX) STATIC_ASSERT_2(COND, SUFFIX)
	85	# define STATIC_ASSERT_DECL(COND) STATIC_ASSERT_1(COND, __LINE__)
	86	#endif
	87	/* We need this wrapper even in C11 because 'case X: static_assert(...);' is an
	88	error (static_assert is a declaration, and only statements can have labels).
	89	*/
	90	#define STATIC_ASSERT_STMT(COND) do { STATIC_ASSERT_DECL(COND); } while (0)
	91	#endif
53	92
54	93	WARNINGS_ENABLE
55
56
57		#define HAVE_PERL_VERSION(R, V, S) \
58		(PERL_REVISION > (R) \|\| (PERL_REVISION == (R) && (PERL_VERSION > (V) \|\| (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
59	94
60	95
61	96	#define MY_PKG "Keyword::Simple"

67	102	#define PL_rsfp_filters (PL_parser->rsfp_filters)
68	103	#endif
69	104
	105	#ifndef PL_parser_filtered
	106	#if HAVE_PERL_VERSION(5, 15, 5)
	107	#define PL_parser_filtered (PL_parser->filtered)
	108	#else
	109	#define PL_parser_filtered 0
	110	#endif
	111	#endif
	112
	113
70	114	static int (next_keyword_plugin)(pTHX_ char , STRLEN, OP **);
71	115
72		static long kw_index(pTHX_ const char *kw_ptr, STRLEN kw_len) {
73		HV *hints;
74		SV sv, *psv;
75		char p, pv;
76		STRLEN pv_len;
77
78		if (!(hints = GvHV(PL_hintgv))) {
79		return -1;
80		}
81		if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) {
82		return -1;
83		}
84		sv = *psv;
85
86		pv = SvPV(sv, pv_len);
87		if (pv_len < 4 \|\| pv_len - 2 <= kw_len) {
88		return -1;
89		}
90
91		for (
92		p = pv;
93		(p = strchr(p + 1, *kw_ptr)) &&
94		p < pv + pv_len - 1 - kw_len;
95		) {
96		if (
97		p[-1] == ' ' &&
98		p[kw_len] == ':' &&
99		memcmp(kw_ptr, p, kw_len) == 0
100		) {
101		if (p[kw_len + 1] == '-') {
102		return -1;
103		}
104		assert(p[kw_len + 1] >= '0' && p[kw_len + 1] <= '9');
105		return strtol(p + kw_len + 1, NULL, 10);
106		}
107		}
108
109		return -1;
	116	static SV kw_handler(pTHX_ const char kw_ptr, STRLEN kw_len) {
	117	HV *hints;
	118	SV *psv, sv, *sv2;
	119	I32 kw_xlen;
	120
	121
	122	/* don't bother doing anything fancy after a syntax error */
	123	if (PL_parser && PL_parser->error_count) {
	124	return NULL;
	125	}
	126
	127	STATIC_ASSERT_STMT(~(STRLEN)0 > (U32)I32_MAX);
	128	if (kw_len > (STRLEN)I32_MAX) {
	129	return NULL;
	130	}
	131
	132	if (!(hints = GvHV(PL_hintgv))) {
	133	return NULL;
	134	}
	135
	136	if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) {
	137	return NULL;
	138	}
	139
	140	sv = *psv;
	141	if (!(SvROK(sv) && (sv2 = SvRV(sv), SvTYPE(sv2) == SVt_PVHV))) {
	142	croak("%s: internal error: $^H{'%s'} not a hashref: %"SVf, MY_PKG, HINTK_KEYWORDS, SVfARG(sv));
	143	}
	144
	145	kw_xlen = kw_len;
	146	if (lex_bufutf8()) {
	147	kw_xlen = -kw_xlen;
	148	}
	149	if (!(psv = hv_fetch((HV *)sv2, kw_ptr, kw_xlen, 0))) {
	150	return NULL;
	151	}
	152
	153	sv = *psv;
	154	if (!(SvROK(sv) && (sv2 = SvRV(sv), SvTYPE(sv2) == SVt_PVCV))) {
	155	croak("%s: internal error: $^H{'%s'}{'%.*s'} not a coderef: %"SVf, MY_PKG, HINTK_KEYWORDS, (int)kw_len, kw_ptr, SVfARG(sv));
	156	}
	157
	158	return sv2;
110	159	}
111	160
112	161	static I32 playback(pTHX_ int idx, SV *buf, int n) {
113		char *ptr;
114		STRLEN len, d;
115		SV *sv = FILTER_DATA(idx);
116
117		ptr = SvPV(sv, len);
118		if (!len) {
119		return 0;
120		}
121
122		if (!n) {
123		char *nl = memchr(ptr, '\n', len);
124		d = nl ? (STRLEN)(nl - ptr + 1) : len;
125		} else {
126		d = n < 0 ? INT_MAX : n;
127		if (d > len) {
128		d = len;
129		}
130		}
131
132		sv_catpvn(buf, ptr, d);
133		sv_chop(sv, ptr + d);
134		return 1;
135		}
136
137		static void total_recall(pTHX_ I32 n) {
138		SV sv, cb;
139		AV *meta;
140		dSP;
141
142		ENTER;
143		SAVETMPS;
144
145		meta = get_av(MY_PKG "::meta", GV_ADD);
146		cb = *av_fetch(meta, n, 0);
147
148		sv = sv_2mortal(newSVpvs(""));
149		if (lex_bufutf8()) {
150		SvUTF8_on(sv);
151		}
152
153		/* sluuuuuurrrrp */
154
155		sv_setpvn(sv, PL_parser->bufptr, PL_parser->bufend - PL_parser->bufptr);
156		lex_unstuff(PL_parser->bufend); /* you saw nothing */
157
158		if (!PL_rsfp_filters) {
159		/* because FILTER_READ fails with filters=null but DTRT with filters=[] */
160		PL_rsfp_filters = newAV();
161		}
162		while (FILTER_READ(0, sv, 4096) > 0)
163		;
164
165		PUSHMARK(SP);
166		mXPUSHs(newRV_inc(sv));
167		PUTBACK;
168
169		call_sv(cb, G_VOID);
170		SPAGAIN;
171
172		{ /* $sv .= "\n" */
173		char *p;
174		STRLEN n;
175		SvPV_force(sv, n);
176		p = SvGROW(sv, n + 2);
177		p[n] = '\n';
178		p[n + 1] = '\0';
179		SvCUR_set(sv, n + 1);
180		}
181
182		filter_add(playback, SvREFCNT_inc_simple_NN(sv));
183
184		CopLINE_dec(PL_curcop);
185
186		PUTBACK;
187		FREETMPS;
188		LEAVE;
	162	char *ptr;
	163	STRLEN len, d;
	164	SV *sv = FILTER_DATA(idx);
	165
	166	ptr = SvPV(sv, len);
	167	if (!len) {
	168	return 0;
	169	}
	170
	171	if (!n) {
	172	char *nl = memchr(ptr, '\n', len);
	173	d = nl ? (STRLEN)(nl - ptr + 1) : len;
	174	} else {
	175	d = n < 0 ? INT_MAX : n;
	176	if (d > len) {
	177	d = len;
	178	}
	179	}
	180
	181	sv_catpvn(buf, ptr, d);
	182	sv_chop(sv, ptr + d);
	183	return 1;
	184	}
	185
	186	static void total_recall(pTHX_ SV *cb) {
	187	SV *sv;
	188	dSP;
	189
	190	ENTER;
	191	SAVETMPS;
	192
	193	sv = sv_2mortal(newSVpvs(""));
	194	if (lex_bufutf8()) {
	195	SvUTF8_on(sv);
	196	}
	197
	198	/* sluuuuuurrrrp */
	199
	200	sv_setpvn(sv, PL_parser->bufptr, PL_parser->bufend - PL_parser->bufptr);
	201	lex_unstuff(PL_parser->bufend); /* you saw nothing */
	202
	203	if (PL_parser->rsfp \|\| PL_parser_filtered) {
	204	if (!PL_rsfp_filters) {
	205	/* because FILTER_READ fails with filters=null but DTRT with filters=[] */
	206	PL_rsfp_filters = newAV();
	207	}
	208	while (FILTER_READ(0, sv, 4096) > 0)
	209	;
	210	}
	211
	212	PUSHMARK(SP);
	213	mXPUSHs(newRV_inc(sv));
	214	PUTBACK;
	215
	216	call_sv(cb, G_VOID);
	217	SPAGAIN;
	218
	219	{ /* $sv .= "\n" */
	220	char *p;
	221	STRLEN n;
	222	SvPV_force(sv, n);
	223	p = SvGROW(sv, n + 2);
	224	p[n] = '\n';
	225	p[n + 1] = '\0';
	226	SvCUR_set(sv, n + 1);
	227	}
	228
	229	if (PL_parser->rsfp \|\| PL_parser_filtered) {
	230	filter_add(playback, SvREFCNT_inc_simple_NN(sv));
	231	CopLINE_dec(PL_curcop);
	232	} else {
	233	lex_stuff_sv(sv, 0);
	234	}
	235
	236	FREETMPS;
	237	LEAVE;
189	238	}
190	239
191	240	static int my_keyword_plugin(pTHX_ char keyword_ptr, STRLEN keyword_len, OP *op_ptr) {
192		long n;
193
194		if ((n = kw_index(aTHX_ keyword_ptr, keyword_len)) >= 0) {
195		total_recall(aTHX_ n);
196		*op_ptr = newOP(OP_NULL, 0);
197		return KEYWORD_PLUGIN_STMT;
198		}
199
200		return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
201		}
202
	241	SV *cb;
	242
	243	if ((cb = kw_handler(aTHX_ keyword_ptr, keyword_len))) {
	244	total_recall(aTHX_ cb);
	245	*op_ptr = newOP(OP_NULL, 0);
	246	return KEYWORD_PLUGIN_STMT;
	247	}
	248
	249	return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
	250	}
	251
	252
	253	static void my_boot(pTHX) {
	254	HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
	255
	256	newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
	257
	258	next_keyword_plugin = PL_keyword_plugin;
	259	PL_keyword_plugin = my_keyword_plugin;
	260	}
203	261
204	262	WARNINGS_RESET
205	263

207	265	PROTOTYPES: ENABLE
208	266
209	267	BOOT:
210		WARNINGS_ENABLE {
211		HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
212		/**/
213		newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
214		/**/
215		next_keyword_plugin = PL_keyword_plugin;
216		PL_keyword_plugin = my_keyword_plugin;
217		} WARNINGS_RESET
	268	my_boot(aTHX);

+63

-21

lib/Keyword/Simple.pm less more

3	3	use warnings;
4	4
5	5	use Carp qw(croak);
6		use B::Hooks::EndOfScope;
7	6
8	7	use XSLoader;
9	8	BEGIN {
10		our $VERSION = '0.03';
11		XSLoader::load __PACKAGE__, $VERSION;
	9	our $VERSION = '0.04';
	10	XSLoader::load __PACKAGE__, $VERSION;
12	11	}
13	12
14		# all shall burn
15		our @meta;
	13	sub define {
	14	my ($kw, $sub) = @_;
	15	$kw =~ /^\p{XIDS}\p{XIDC}*\z/ or croak "'$kw' doesn't look like an identifier";
	16	ref($sub) eq 'CODE' or croak "'$sub' doesn't look like a coderef";
16	17
17		sub define {
18		my ($kw, $sub) = @_;
19		$kw =~ /^\p{XIDS}\p{XIDC}*\z/ or croak "'$kw' doesn't look like an identifier";
20		ref($sub) eq 'CODE' or croak "'$sub' doesn't look like a coderef";
21
22		my $n = @meta;
23		push @meta, $sub;
24
25		$^H{+HINTK_KEYWORDS} .= " $kw:$n";
26		on_scope_end {
27		delete $meta[$n];
28		};
	18	my %keywords = %{$^H{+HINTK_KEYWORDS} // {}};
	19	$keywords{$kw} = $sub;
	20	$^H{+HINTK_KEYWORDS} = \%keywords;
29	21	}
30	22
31	23	sub undefine {
32		my ($kw) = @_;
33		$kw =~ /^\p{XIDS}\p{XIDC}*\z/ or croak "'$kw' doesn't look like an identifier";
	24	my ($kw) = @_;
	25	$kw =~ /^\p{XIDS}\p{XIDC}*\z/ or croak "'$kw' doesn't look like an identifier";
34	26
35		$^H{+HINTK_KEYWORDS} .= " $kw:-";
	27	my %keywords = %{$^H{+HINTK_KEYWORDS} // {}};
	28	delete $keywords{$kw};
	29	$^H{+HINTK_KEYWORDS} = \%keywords;
36	30	}
37	31
38	32	'ok'

40	34	__END__
41	35
42	36	=encoding UTF-8
	37
	38	=for highlighter language=perl
43	39
44	40	=head1 NAME
45	41

126	122	This also means your new keywords can only occur at the beginning of a
127	123	statement, not embedded in an expression.
128	124
	125	Keywords in the replacement part of a C<s//.../e> substitution aren't handled
	126	correctly and break parsing.
	127
129	128	There are barely any tests.
	129
	130	=begin :README
	131
	132	=head1 INSTALLATION
	133
	134	To download and install this module, use your favorite CPAN client, e.g.
	135	L<C<cpan>\|cpan>:
	136
	137	=for highlighter language=sh
	138
	139	cpan Keyword::Simple
	140
	141	Or L<C<cpanm>\|cpanm>:
	142
	143	cpanm Keyword::Simple
	144
	145	To do it manually, run the following commands (after downloading and unpacking
	146	the tarball):
	147
	148	perl Makefile.PL
	149	make
	150	make test
	151	make install
	152
	153	=end :README
	154
	155	=head1 SUPPORT AND DOCUMENTATION
	156
	157	After installing, you can find documentation for this module with the
	158	L<C<perldoc>\|perldoc> command.
	159
	160	=for highlighter language=sh
	161
	162	perldoc Keyword::Simple
	163
	164	You can also look for information at
	165	L<https://metacpan.org/pod/Keyword::Simple>.
	166
	167	To see a list of open bugs, visit
	168	L<https://rt.cpan.org/Public/Dist/Display.html?Name=Keyword-Simple>.
	169
	170	To report a new bug, send an email to
	171	C<bug-Keyword-Simple [at] rt.cpan.org>.
130	172
131	173	=head1 AUTHOR
132	174

134	176
135	177	=head1 COPYRIGHT & LICENSE
136	178
137		Copyright 2012, 2013 Lukas Mai.
	179	Copyright (C) 2012, 2013 Lukas Mai.
138	180
139	181	This program is free software; you can redistribute it and/or modify it
140	182	under the terms of either: the GNU General Public License as published

+11

-11

t/basic.t less more

4	4	use Test::More tests => 2;
5	5
6	6	{
7		package Foo;
	7	package Foo;
8	8
9		use Keyword::Simple;
	9	use Keyword::Simple;
10	10
11		sub import {
12		Keyword::Simple::define peek => sub {
13		substr ${$_[0]}, 0, 0, "ok 1, 'synthetic test';";
14		};
15		}
	11	sub import {
	12	Keyword::Simple::define peek => sub {
	13	substr ${$_[0]}, 0, 0, "ok 1, 'synthetic test';";
	14	};
	15	}
16	16
17		sub unimport {
18		Keyword::Simple::undefine 'peek';
19		}
	17	sub unimport {
	18	Keyword::Simple::undefine 'peek';
	19	}
20	20
21		BEGIN { $INC{"Foo.pm"} = 1; }
	21	BEGIN { $INC{"Foo.pm"} = 1; }
22	22	}
23	23
24	24	use Foo;

+58

-0

t/eval.t less more

	0	#!perl
	1	use strict;
	2	use warnings FATAL => 'all';
	3	no warnings 'once';
	4
	5	use Test::More;
	6
	7	{
	8	package Foo;
	9
	10	use Keyword::Simple;
	11
	12	sub import {
	13	Keyword::Simple::define class => sub {
	14	substr ${$_[0]}, 0, 0, "package";
	15	};
	16	}
	17
	18	sub unimport {
	19	Keyword::Simple::undefine 'peek';
	20	}
	21
	22	BEGIN { $INC{"Foo.pm"} = 1; }
	23	}
	24
	25	use Foo;
	26
	27	{ class Gpkg0; our $v = __PACKAGE__; }
	28	is $Gpkg0::v, 'Gpkg0';
	29
	30	eval q{ class Gpkg1; our $v = __PACKAGE__ };
	31	is $@, '';
	32	is $Gpkg1::v, 'Gpkg1';
	33
	34	SKIP: {
	35	skip "evalbytes() requires v5.16", 3
	36	if $^V lt v5.16;
	37	my $err;
	38	eval q{
	39	use v5.16;
	40	evalbytes q{ class Gpkg2; our $v = __PACKAGE__ };
	41	$err = $@;
	42	};
	43	is $@, '';
	44	is $err, '';
	45	is $Gpkg2::v, 'Gpkg2';
	46	}
	47
	48	TODO: {
	49	local $TODO = 's//.../e handling is broken';
	50	my $str = '';
	51	eval q{ $str =~ s/^/ class Gpkg3; our $v = __PACKAGE__ /e };
	52	is $@, '';
	53	is $str, 'Gpkg3';
	54	is $Gpkg3::v, 'Gpkg3';
	55	}
	56
	57	done_testing;

+15

-15

t/lineno.t less more

4	4	use Test::More tests => 6;
5	5
6	6	BEGIN {
7		package Some::Module;
8		use Keyword::Simple;
9		sub import {
10		Keyword::Simple::define 'provided', sub {
11		my ($ref) = @_;
12		substr($$ref, 0, 0) = 'if';
13		};
14		}
15		sub unimport {
16		Keyword::Simple::undefine 'provided';
17		}
18		$INC{'Some/Module.pm'} = __FILE__;
	7	package Some::Module;
	8	use Keyword::Simple;
	9	sub import {
	10	Keyword::Simple::define 'provided', sub {
	11	my ($ref) = @_;
	12	substr($$ref, 0, 0) = 'if';
	13	};
	14	}
	15	sub unimport {
	16	Keyword::Simple::undefine 'provided';
	17	}
	18	$INC{'Some/Module.pm'} = __FILE__;
19	19	};
20	20
21	21	use Some::Module;
22	22
23	23	provided (1) {
24		is(__LINE__, 25);
	24	is(__LINE__, 25);
25	25	}
26	26
27	27	#line 1

34	34	is __LINE__, 2;
35	35
36	36	provided (2) { provided (3) {
37		is __LINE__, 5;
38		}
	37	is __LINE__, 5;
	38	}
39	39	}

-14

~~t/pod.t~~ less more

0		#!perl
1
2		use strict;
3		use warnings;
4		use Test::More;
5
6		plan skip_all => "set RELEASE_TESTING=1 to run this test" unless $ENV{RELEASE_TESTING};
7
8		# Ensure a recent version of Test::Pod
9		my $min_tp = 1.22;
10		eval "use Test::Pod $min_tp";
11		plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
12
13		all_pod_files_ok();

-0

xt/pod.t less more

	0	#!perl
	1
	2	use strict;
	3	use warnings;
	4	use Test::Pod 1.22;
	5
	6	all_pod_files_ok();