From 5f63aea760983e224ccfb2491d56a0f929909a01 Mon Sep 17 00:00:00 2001 From: sevan Date: Fri, 28 Apr 2017 22:59:48 +0000 Subject: Patch for issue raised in Russ Cox's "Glob Matching Can Be Simple And Fast Too" post. https://research.swtch.com/glob https://perl5.git.perl.org/perl.git/commit/33252c318625f3c6c89b816ee88481940e3e6f95 Reviewed by: wiz --- lang/perl5/Makefile.common | 3 +- lang/perl5/distinfo | 5 +- lang/perl5/patches/patch-MANIFEST | 16 ++++ lang/perl5/patches/patch-ext_File-Glob_bsd_glob.c | 89 ++++++++++++++++++ .../perl5/patches/patch-ext_File-Glob_t_rt131211.t | 103 +++++++++++++++++++++ 5 files changed, 214 insertions(+), 2 deletions(-) create mode 100644 lang/perl5/patches/patch-MANIFEST create mode 100644 lang/perl5/patches/patch-ext_File-Glob_bsd_glob.c create mode 100644 lang/perl5/patches/patch-ext_File-Glob_t_rt131211.t (limited to 'lang') diff --git a/lang/perl5/Makefile.common b/lang/perl5/Makefile.common index ab2a997c3cc..b93a505b2af 100644 --- a/lang/perl5/Makefile.common +++ b/lang/perl5/Makefile.common @@ -1,9 +1,10 @@ -# $NetBSD: Makefile.common,v 1.28 2017/01/27 09:39:40 adam Exp $ +# $NetBSD: Makefile.common,v 1.29 2017/04/28 22:59:48 sevan Exp $ # # used by lang/perl5/Makefile # used by databases/p5-gdbm/Makefile DISTNAME= perl-5.24.1 +PKGREVISION= 1 CATEGORIES= lang devel perl5 MASTER_SITES= ${MASTER_SITE_PERL_CPAN:S,/modules/by-module/$,/src/5.0/,} DISTFILES+= ${DISTNAME}${EXTRACT_SUFX} diff --git a/lang/perl5/distinfo b/lang/perl5/distinfo index 3bf0a84b6da..1c271338a88 100644 --- a/lang/perl5/distinfo +++ b/lang/perl5/distinfo @@ -1,10 +1,11 @@ -$NetBSD: distinfo,v 1.139 2017/01/27 09:39:40 adam Exp $ +$NetBSD: distinfo,v 1.140 2017/04/28 22:59:48 sevan Exp $ SHA1 (perl-5.24.1.tar.bz2) = d43ac3d39686462f86eed35b3c298ace74f1ffa0 RMD160 (perl-5.24.1.tar.bz2) = e824cb74998ebbbc3286fa353e64e75104d4c5b1 SHA512 (perl-5.24.1.tar.bz2) = 5a6e5f5fcd65e7add7ba2126d530a8e2a912cb076cfe61bbf7e49b28e4e63aa0d474183a6f8a388c67d03ea6a44f367efb3b3a768e971ef52b769e737eeb048b Size (perl-5.24.1.tar.bz2) = 14088312 bytes SHA1 (patch-Configure) = 13455c1b32b0f602b339787af4ddcd481f9c2dd5 +SHA1 (patch-MANIFEST) = 7037a7a1881da3d2db03d4a5d6a61a7a6d3bc11b SHA1 (patch-Makefile.SH) = 32ffc30831b0af49f90119510021037b066367dc SHA1 (patch-aa) = 9bbcc9395080b11934528a32808e0a509f1d831c SHA1 (patch-ab) = c899b7221a78e74cc9b1480834baba047dd19f38 @@ -17,6 +18,8 @@ SHA1 (patch-cn) = d1877383e213a414562b5bb4c1e8aa785926fab7 SHA1 (patch-dist_Carp_lib_Carp.pm) = fb628ee983462cec9303ceea09852378ec654ecf SHA1 (patch-dist_Time-HiRes_HiRes.xs) = 067911a23881d48d2ad431076b3babeb585b83d7 SHA1 (patch-ext_Errno_Errno__pm.PL) = 4f135e267da17de38f8f1e7e03d5209bfd09a323 +SHA1 (patch-ext_File-Glob_bsd_glob.c) = e43252b55f04bb1cd69d48e8155aa110532c9fbe +SHA1 (patch-ext_File-Glob_t_rt131211.t) = 9aeddad078cdc920e64ed2e73f952be341745d7e SHA1 (patch-ext_XS-APItest_Makefile.PL) = 7094aa4cb021c1f29054a40c4f5f4c15c59f13de SHA1 (patch-hints_cygwin.sh) = 1b21d927d6b7379754c4cd64a2b05d3632c35470 SHA1 (patch-hints_netbsd.sh) = 0d549a48800372d75fe34b783529a78cba90f646 diff --git a/lang/perl5/patches/patch-MANIFEST b/lang/perl5/patches/patch-MANIFEST new file mode 100644 index 00000000000..9ee79796ee8 --- /dev/null +++ b/lang/perl5/patches/patch-MANIFEST @@ -0,0 +1,16 @@ +$NetBSD: patch-MANIFEST,v 1.1 2017/04/28 22:59:48 sevan Exp $ + +[perl #131211] fixup File::Glob degenerate matching +https://research.swtch.com/glob +https://perl5.git.perl.org/perl.git/commit/33252c318625f3c6c89b816ee88481940e3e6f95 + +--- MANIFEST.orig 2017-04-28 18:35:00.000000000 +0000 ++++ MANIFEST +@@ -3706,6 +3706,7 @@ ext/File-Glob/t/case.t See if File::Glo + ext/File-Glob/t/global.t See if File::Glob works + ext/File-Glob/TODO File::Glob extension todo list + ext/File-Glob/t/rt114984.t See if File::Glob works ++ext/File-Glob/t/rt131211.t See if File::Glob works + ext/File-Glob/t/taint.t See if File::Glob works + ext/File-Glob/t/threads.t See if File::Glob + threads works + ext/GDBM_File/GDBM_File.pm GDBM extension Perl module diff --git a/lang/perl5/patches/patch-ext_File-Glob_bsd_glob.c b/lang/perl5/patches/patch-ext_File-Glob_bsd_glob.c new file mode 100644 index 00000000000..2eb2aa8a184 --- /dev/null +++ b/lang/perl5/patches/patch-ext_File-Glob_bsd_glob.c @@ -0,0 +1,89 @@ +$NetBSD: patch-ext_File-Glob_bsd_glob.c,v 1.1 2017/04/28 22:59:48 sevan Exp $ + +[perl #131211] fixup File::Glob degenerate matching +https://research.swtch.com/glob +https://perl5.git.perl.org/perl.git/commit/33252c318625f3c6c89b816ee88481940e3e6f95 + +--- ext/File-Glob/bsd_glob.c.orig 2017-04-28 18:41:33.000000000 +0000 ++++ ext/File-Glob/bsd_glob.c +@@ -911,33 +911,43 @@ globextend(const Char *path, glob_t *pgl + /* + * pattern matching function for filenames. Each occurrence of the * + * pattern causes a recursion level. ++ * ++ * Note, this function differs from the original as per the discussion ++ * here: https://research.swtch.com/glob ++ * ++ * Basically we removed the recursion and made it use the algorithm ++ * from Russ Cox to not go quadratic on cases like a file called ("a" x 100) . "x" ++ * matched against a pattern like "a*a*a*a*a*a*a*y". ++ * + */ + static int + match(Char *name, Char *pat, Char *patend, int nocase) + { + int ok, negate_range; + Char c, k; ++ Char *nextp = NULL; ++ Char *nextn = NULL; + ++ loop: + while (pat < patend) { + c = *pat++; + switch (c & M_MASK) { + case M_ALL: + if (pat == patend) + return(1); +- do +- if (match(name, pat, patend, nocase)) +- return(1); +- while (*name++ != BG_EOS) +- ; +- return(0); ++ if (*name == BG_EOS) ++ return 0; ++ nextn = name + 1; ++ nextp = pat - 1; ++ break; + case M_ONE: + if (*name++ == BG_EOS) +- return(0); ++ goto fail; + break; + case M_SET: + ok = 0; + if ((k = *name++) == BG_EOS) +- return(0); ++ goto fail; + if ((negate_range = ((*pat & M_MASK) == M_NOT)) != BG_EOS) + ++pat; + while (((c = *pat++) & M_MASK) != M_END) +@@ -953,16 +963,25 @@ match(Char *name, Char *pat, Char *paten + } else if (nocase ? (tolower(c) == tolower(k)) : (c == k)) + ok = 1; + if (ok == negate_range) +- return(0); ++ goto fail; + break; + default: + k = *name++; + if (nocase ? (tolower(k) != tolower(c)) : (k != c)) +- return(0); ++ goto fail; + break; + } + } +- return(*name == BG_EOS); ++ if (*name == BG_EOS) ++ return 1; ++ ++ fail: ++ if (nextn) { ++ pat = nextp; ++ name = nextn; ++ goto loop; ++ } ++ return 0; + } + + /* Free allocated data belonging to a glob_t structure. */ diff --git a/lang/perl5/patches/patch-ext_File-Glob_t_rt131211.t b/lang/perl5/patches/patch-ext_File-Glob_t_rt131211.t new file mode 100644 index 00000000000..7d06847650b --- /dev/null +++ b/lang/perl5/patches/patch-ext_File-Glob_t_rt131211.t @@ -0,0 +1,103 @@ +$NetBSD: patch-ext_File-Glob_t_rt131211.t,v 1.1 2017/04/28 22:59:48 sevan Exp $ + +[perl #131211] fixup File::Glob degenerate matching +https://research.swtch.com/glob +https://perl5.git.perl.org/perl.git/commit/33252c318625f3c6c89b816ee88481940e3e6f95 + +--- ext/File-Glob/t/rt131211.t.orig 2017-04-28 18:37:15.000000000 +0000 ++++ ext/File-Glob/t/rt131211.t +@@ -0,0 +1,94 @@ ++use strict; ++use warnings; ++use v5.16.0; ++use File::Temp 'tempdir'; ++use File::Spec::Functions; ++use Test::More; ++use Time::HiRes qw(time); ++ ++plan tests => 13; ++ ++my $path = tempdir uc cleanup => 1; ++my @files= ( ++ "x".("a" x 50)."b", # 0 ++ "abbbbbbbbbbbbc", # 1 ++ "abbbbbbbbbbbbd", # 2 ++ "aaabaaaabaaaabc", # 3 ++ "pq", # 4 ++ "r", # 5 ++ "rttiiiiiii", # 6 ++ "wewewewewewe", # 7 ++ "weeeweeeweee", # 8 ++ "weewweewweew", # 9 ++ "wewewewewewewewewewewewewewewewewq", # 10 ++ "wtttttttetttttttwr", # 11 ++); ++ ++ ++foreach (@files) { ++ open(my $f, ">", catfile $path, $_); ++} ++ ++my $elapsed_fail= 0; ++my $elapsed_match= 0; ++my @got_files; ++my @no_files; ++my $count = 0; ++ ++while (++$count < 10) { ++ $elapsed_match -= time; ++ @got_files= glob catfile $path, "x".("a*" x $count) . "b"; ++ $elapsed_match += time; ++ ++ $elapsed_fail -= time; ++ @no_files= glob catfile $path, "x".("a*" x $count) . "c"; ++ $elapsed_fail += time; ++ last if $elapsed_fail > $elapsed_match * 100; ++} ++ ++is $count,10, ++ "tried all the patterns without bailing out"; ++ ++cmp_ok $elapsed_fail/$elapsed_match,"<",2, ++ "time to fail less than twice the time to match"; ++is "@got_files", catfile($path, $files[0]), ++ "only got the expected file for xa*..b"; ++is "@no_files", "", "shouldnt have files for xa*..c"; ++ ++ ++@got_files= glob catfile $path, "a*b*b*b*bc"; ++is "@got_files", catfile($path, $files[1]), ++ "only got the expected file for a*b*b*b*bc"; ++ ++@got_files= sort glob catfile $path, "a*b*b*bc"; ++is "@got_files", catfile($path, $files[3])." ".catfile($path,$files[1]), ++ "got the expected two files for a*b*b*bc"; ++ ++@got_files= sort glob catfile $path, "p*"; ++is "@got_files", catfile($path, $files[4]), ++ "p* matches pq"; ++ ++@got_files= sort glob catfile $path, "r*???????"; ++is "@got_files", catfile($path, $files[6]), ++ "r*??????? works as expected"; ++ ++@got_files= sort glob catfile $path, "w*e*w??e"; ++is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (7,8)), ++ "w*e*w??e works as expected"; ++ ++@got_files= sort glob catfile $path, "w*e*we??"; ++is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (7,8,9,10)), ++ "w*e*we?? works as expected"; ++ ++@got_files= sort glob catfile $path, "w**e**w"; ++is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (9)), ++ "w**e**w works as expected"; ++ ++@got_files= sort glob catfile $path, "*wee*"; ++is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (8,9)), ++ "*wee* works as expected"; ++ ++@got_files= sort glob catfile $path, "we*"; ++is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (7,8,9,10)), ++ "we* works as expected"; ++ -- cgit v1.2.3