In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/50d61629dc7fe34f077b9f66c50287d839e06378?hp=104393a727efd8bd71ca6d7f9b0d20a5b92fde48>
- Log -----------------------------------------------------------------
commit 50d61629dc7fe34f077b9f66c50287d839e06378
Author: Nicholas Clark <n...@ccl4.org>
Date: Tue Feb 17 23:24:32 2009 +0000
Pass the length of the string to S_incpush_use_sep(), where known.
M embed.fnc
M embed.h
M perl.c
M proto.h
commit 72533a49cbed2661d6c2811089631bb401aef2c7
Author: Nicholas Clark <n...@ccl4.org>
Date: Tue Feb 17 22:57:56 2009 +0000
Tests for S_incpush_use_sep() splitting on : (or platform equivalent)
M t/run/runenv.t
commit d5226c4c8f9a293280b320d06c082073daeb75b1
Author: Nicholas Clark <n...@ccl4.org>
Date: Tue Feb 17 20:18:39 2009 +0000
In runenv.t, break apart running perl and testing the output into two
functions.
M t/run/runenv.t
-----------------------------------------------------------------------
Summary of changes:
embed.fnc | 2 +-
embed.h | 2 +-
perl.c | 75 ++++++++++++++++++++++++++------------------------
proto.h | 2 +-
t/run/runenv.t | 84 ++++++++++++++++++++++++++++++++++++++++++++-----------
5 files changed, 109 insertions(+), 56 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index cd3e015..522cf7c 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1475,7 +1475,7 @@ s |void |find_beginning |NN SV* linestr_sv|NN PerlIO
*rsfp
s |void |forbid_setid |const char flag|const bool suidscript
s |void |incpush |NULLOK const char *const dir|STRLEN len \
|U32 flags
-s |void |incpush_use_sep|NN const char *p|U32 flags
+s |void |incpush_use_sep|NN const char *p|STRLEN len|U32 flags
s |void |init_interp
s |void |init_ids
s |void |init_main_stash
diff --git a/embed.h b/embed.h
index 0d3cbf3..cfe24ca 100644
--- a/embed.h
+++ b/embed.h
@@ -3627,7 +3627,7 @@
#define find_beginning(a,b) S_find_beginning(aTHX_ a,b)
#define forbid_setid(a,b) S_forbid_setid(aTHX_ a,b)
#define incpush(a,b,c) S_incpush(aTHX_ a,b,c)
-#define incpush_use_sep(a,b) S_incpush_use_sep(aTHX_ a,b)
+#define incpush_use_sep(a,b,c) S_incpush_use_sep(aTHX_ a,b,c)
#define init_interp() S_init_interp(aTHX)
#define init_ids() S_init_ids(aTHX)
#define init_main_stash() S_init_main_stash(aTHX)
diff --git a/perl.c b/perl.c
index ba45aac..cf7ef08 100644
--- a/perl.c
+++ b/perl.c
@@ -4108,11 +4108,11 @@ S_init_perllib(pTHX_ U32 old_vers)
#else
if (s)
#endif
- incpush_use_sep(s, old_vers ? old_vers : INCPUSH_ADD_SUB_DIRS);
+ incpush_use_sep(s, 0, old_vers ? old_vers : INCPUSH_ADD_SUB_DIRS);
else if (!old_vers) {
s = PerlEnv_getenv("PERLLIB");
if (s)
- incpush_use_sep(s, 0);
+ incpush_use_sep(s, 0, 0);
}
#else /* VMS */
/* Treat PERL5?LIB as a possible search list logical name -- the
@@ -4123,11 +4123,11 @@ S_init_perllib(pTHX_ U32 old_vers)
int idx = 0;
if (my_trnlnm("PERL5LIB",buf,0))
do {
- incpush_use_sep(buf, old_vers ? old_vers :
INCPUSH_ADD_SUB_DIRS);
+ incpush_use_sep(buf, 0, old_vers ? old_vers :
INCPUSH_ADD_SUB_DIRS);
} while (my_trnlnm("PERL5LIB",buf,++idx));
else if (!old_vers)
while (my_trnlnm("PERLLIB",buf,idx++))
- incpush_use_sep(buf, 0);
+ incpush_use_sep(buf, 0, 0);
#endif /* VMS */
}
@@ -4136,9 +4136,9 @@ S_init_perllib(pTHX_ U32 old_vers)
*/
#ifdef APPLLIB_EXP
if (!old_vers) {
- incpush_use_sep(APPLLIB_EXP, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
} else {
- incpush_use_sep(APPLLIB_EXP, old_vers|INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
old_vers|INCPUSH_CAN_RELOCATE);
}
#endif
@@ -4153,14 +4153,14 @@ S_init_perllib(pTHX_ U32 old_vers)
# ifdef ARCHLIB_EXP
if (!old_vers)
- incpush_use_sep(ARCHLIB_EXP, INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP),
INCPUSH_CAN_RELOCATE);
# endif
Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
- incpush_use_sep(SvPVX(privdir), INCPUSH_ADD_SUB_DIRS);
+ incpush_use_sep(SvPVX(privdir), SvCUR(privdir),
INCPUSH_ADD_SUB_DIRS);
Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
- if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
+ if (PerlLIO_stat(SvPVX(privdir), SvCUR(privdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
incpush_use_sep(SvPVX(privdir), INCPUSH_ADD_SUB_DIRS);
SvREFCNT_dec(privdir);
@@ -4172,7 +4172,7 @@ S_init_perllib(pTHX_ U32 old_vers)
/* sitearch is always relative to sitelib on Windows for
* DLL-based path intuition to work correctly */
# if !defined(WIN32)
- incpush_use_sep(SITEARCH_EXP, INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP),
INCPUSH_CAN_RELOCATE);
# endif
#endif
@@ -4181,16 +4181,16 @@ S_init_perllib(pTHX_ U32 old_vers)
/* this picks up sitearch as well */
s = win32_get_sitelib(PERL_FS_VERSION);
if (s)
- incpush_use_sep(s, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
+ incpush_use_sep(s, 0, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
# else
- incpush_use_sep(SITELIB_EXP, INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP),
INCPUSH_CAN_RELOCATE);
# endif
#endif
}
#if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
/* Search for version-specific dirs below here */
- incpush_use_sep(SITELIB_STEM, old_vers|INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM),
old_vers|INCPUSH_CAN_RELOCATE);
#endif
if (!old_vers) {
@@ -4198,7 +4198,7 @@ S_init_perllib(pTHX_ U32 old_vers)
/* vendorarch is always relative to vendorlib on Windows for
* DLL-based path intuition to work correctly */
# if !defined(WIN32)
- incpush_use_sep(PERL_VENDORARCH_EXP, INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP),
INCPUSH_CAN_RELOCATE);
# endif
#endif
@@ -4207,21 +4207,21 @@ S_init_perllib(pTHX_ U32 old_vers)
/* this picks up vendorarch as well */
s = win32_get_vendorlib(PERL_FS_VERSION);
if (s)
- incpush_use_sep(s, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
+ incpush_use_sep(s, 0, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
# else
- incpush_use_sep(PERL_VENDORLIB_EXP, INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP),
INCPUSH_CAN_RELOCATE);
# endif
#endif
}
#if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
/* Search for version-specific dirs below here */
- incpush_use_sep(PERL_VENDORLIB_STEM, old_vers|INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM),
old_vers|INCPUSH_CAN_RELOCATE);
#endif
if (!old_vers) {
#ifdef ARCHLIB_EXP
- incpush_use_sep(ARCHLIB_EXP, INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP),
INCPUSH_CAN_RELOCATE);
#endif
#ifndef PRIVLIB_EXP
@@ -4231,18 +4231,18 @@ S_init_perllib(pTHX_ U32 old_vers)
#if defined(WIN32)
s = win32_get_privlib(PERL_FS_VERSION);
if (s)
- incpush_use_sep(s, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
+ incpush_use_sep(s, 0, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
#else
- incpush_use_sep(PRIVLIB_EXP, INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP),
INCPUSH_CAN_RELOCATE);
#endif
}
#ifdef PERL_OTHERLIBDIRS
if (!old_vers) {
- incpush_use_sep(PERL_OTHERLIBDIRS, INCPUSH_ADD_SUB_DIRS
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
INCPUSH_ADD_SUB_DIRS
|INCPUSH_CAN_RELOCATE);
} else {
- incpush_use_sep(PERL_OTHERLIBDIRS, old_vers|INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
old_vers|INCPUSH_CAN_RELOCATE);
}
#endif
@@ -4544,33 +4544,36 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32
flags)
}
STATIC void
-S_incpush_use_sep(pTHX_ const char *p, U32 flags)
+S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
{
+ const char *s;
+ const char *end;
/* This logic has been broken out from S_incpush(). It may be possible to
simplify it. */
PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
+ if (!len)
+ len = strlen(p);
+
+ end = p + len;
+
/* Break at all separators */
- while (*p) {
- const char *s;
+ while ((s = memchr(p, PERLLIB_SEP, end - p))) {
+ if (s == p) {
+ /* skip any consecutive separators */
- /* skip any consecutive separators */
- while ( *p == PERLLIB_SEP ) {
/* Uncomment the next line for PATH semantics */
+ /* But you'll need to write tests */
/* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
- p++;
- }
-
- if ((s = strchr(p, PERLLIB_SEP)) != NULL ) {
+ } else {
incpush(p, (STRLEN)(s - p), flags);
- p = s + 1;
- }
- else {
- incpush(p, 0, flags);
- return;
}
+ p = s + 1;
}
+ if (p != end)
+ incpush(p, (STRLEN)(end - p), flags);
+
}
void
diff --git a/proto.h b/proto.h
index 0fb1c33..24665c0 100644
--- a/proto.h
+++ b/proto.h
@@ -4760,7 +4760,7 @@ STATIC void S_find_beginning(pTHX_ SV* linestr_sv,
PerlIO *rsfp)
STATIC void S_forbid_setid(pTHX_ const char flag, const bool suidscript);
STATIC void S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags);
-STATIC void S_incpush_use_sep(pTHX_ const char *p, U32 flags)
+STATIC void S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_INCPUSH_USE_SEP \
assert(p)
diff --git a/t/run/runenv.t b/t/run/runenv.t
index 5012359..1d2a6a7 100644
--- a/t/run/runenv.t
+++ b/t/run/runenv.t
@@ -15,7 +15,7 @@ BEGIN {
require './test.pl'
}
-plan tests => 17;
+plan tests => 75;
my $STDOUT = tempfile();
my $STDERR = tempfile();
@@ -26,18 +26,12 @@ delete $ENV{PERLLIB};
delete $ENV{PERL5LIB};
delete $ENV{PERL5OPT};
-# Run perl with specified environment and arguments returns a list.
-# First element is true if Perl's stdout and stderr match the
-# supplied $stdout and $stderr argument strings exactly.
-# second element is an explanation of the failure
-sub runperl {
- local *F;
- my ($env, $args, $stdout, $stderr) = @_;
+sub runperl_and_capture {
+ local *F;
+ my ($env, $args) = @_;
unshift @$args, '-I../lib';
- $stdout = '' unless defined $stdout;
- $stderr = '' unless defined $stderr;
local %ENV = %ENV;
delete $ENV{PERLLIB};
delete $ENV{PERL5LIB};
@@ -54,13 +48,7 @@ sub runperl {
open F, "< $STDERR" or return (0, "Couldn't read $STDERR file");
{ local $/; $actual_stderr = <F> }
- if ($actual_stdout ne $stdout) {
- return (0, "Stdout mismatch: expected [$stdout], saw [$actual_stdout]");
- } elsif ($actual_stderr ne $stderr) {
- return (0, "Stderr mismatch: expected [$stderr], saw [$actual_stderr]");
- } else {
- return 1; # success
- }
+ return ($actual_stdout, $actual_stderr);
} else { # child
for my $k (keys %$env) {
$ENV{$k} = $env->{$k};
@@ -72,6 +60,22 @@ sub runperl {
}
}
+# Run perl with specified environment and arguments returns a list.
+# First element is true if Perl's stdout and stderr match the
+# supplied $stdout and $stderr argument strings exactly.
+# second element is an explanation of the failure
+sub runperl {
+ local *F;
+ my ($env, $args, $stdout, $stderr) = @_;
+ my ($actual_stdout, $actual_stderr) = runperl_and_capture($env, $args);
+ if ($actual_stdout ne $stdout) {
+ return (0, "Stdout mismatch: expected [$stdout], saw [$actual_stdout]");
+ } elsif ($actual_stderr ne $stderr) {
+ return (0, "Stderr mismatch: expected [$stderr], saw [$actual_stderr]");
+ } else {
+ return 1; # success
+ }
+}
sub it_didnt_work {
print STDOUT "IWHCWJIHCI\cNHJWCJQWKJQJWCQW\n";
@@ -185,6 +189,52 @@ try({PERL5LIB => "foo",
'',
'');
+# Tests for S_incpush_use_sep():
+
+my @dump_inc = ('-e', 'print "$_\n" foreach @INC');
+
+my ($out, $err) = runperl_and_capture({}, [...@dump_inc]);
+
+is ($err, '', 'No errors when determining @INC');
+
+my @default_inc = split /\n/, $out;
+
+is (shift @default_inc, '../lib', 'Our -I../lib is at the front');
+
+my $sep = $Config{path_sep};
+foreach (['nothing', ''],
+ ['something', 'zwapp', 'zwapp'],
+ ['two things', "zwapp${sep}bam", 'zwapp', 'bam'],
+ ['two things, ::', "zwapp${sep}${sep}bam", 'zwapp', 'bam'],
+ [': at start', "${sep}zwapp", 'zwapp'],
+ [': at end', "zwapp${sep}", 'zwapp'],
+ [':: sandwich ::', "${sep}${sep}zwapp${sep}${sep}", 'zwapp'],
+ [':', "${sep}"],
+ ['::', "${sep}${sep}"],
+ [':::', "${sep}${sep}${sep}"],
+ ['two things and :', "zwapp${sep}bam${sep}", 'zwapp', 'bam'],
+ [': and two things', "${sep}zwapp${sep}bam", 'zwapp', 'bam'],
+ [': two things :', "${sep}zwapp${sep}bam${sep}", 'zwapp', 'bam'],
+ ['three things', "zwapp${sep}bam${sep}${sep}owww",
+ 'zwapp', 'bam', 'owww'],
+ ) {
+ my ($name, $lib, @expect) = @$_;
+ push @expect, @default_inc;
+
+ ($out, $err) = runperl_and_capture({PERL5LIB => $lib}, [...@dump_inc]);
+
+ is ($err, '', "No errors when determining \...@inc for $name");
+
+ my @inc = split /\n/, $out;
+
+ is (shift @inc, '../lib', 'Our -I../lib is at the front for $name');
+
+ is (scalar @inc, scalar @expect,
+ "expected number of elements in \...@inc for $name");
+
+ is ("@inc", "@expect", "expected elements in \...@inc for $name");
+}
+
# PERL5LIB tests with included arch directories still missing
END {
--
Perl5 Master Repository
