├── sandbox ├── perl.supp ├── leaktest ├── genMETA.pl ├── used-by.pl └── genMETA.pm ├── .aspell.local.pws ├── .gitignore ├── .whitesource ├── t ├── 00_pod.t ├── 01_pod.t ├── 60_filter.t ├── 40_comma.t ├── 50_sub.t ├── 20_margin.t ├── 70_misc.t └── 80_error.t ├── MANIFEST ├── MANIFEST.SKIP ├── cpanfile ├── .releaserc ├── examples └── box.pl ├── .travis.yml ├── CONTRIBUTING.md ├── README ├── doc ├── OutputFilter.md ├── OutputFilter.man ├── OutputFilter.html └── OutputFilter.3 ├── Makefile.PL ├── Changes ├── SECURITY.md └── OutputFilter.pm /sandbox/perl.supp: -------------------------------------------------------------------------------- 1 | /pro/3gl/CPAN/perl/t/perl.supp -------------------------------------------------------------------------------- /.aspell.local.pws: -------------------------------------------------------------------------------- 1 | personal_ws-1.1 en 2 2 | OutputFilter 3 | STDOUT 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | blib 2 | cover_db 3 | Makefile 4 | META.json 5 | META.yml 6 | MYMETA.json 7 | MYMETA.yml 8 | pm_to_blib 9 | *.tar.gz 10 | *.tgz 11 | *.old 12 | *.tmp 13 | -------------------------------------------------------------------------------- /.whitesource: -------------------------------------------------------------------------------- 1 | { 2 | "generalSettings": { 3 | "shouldScanRepo": true 4 | }, 5 | "checkRunSettings": { 6 | "vulnerableCheckRunConclusionLevel": "failure" 7 | } 8 | } 9 | -------------------------------------------------------------------------------- /t/00_pod.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use Test::More; 4 | 5 | eval "use Test::Pod 1.00"; 6 | plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; 7 | all_pod_files_ok (); 8 | -------------------------------------------------------------------------------- /t/01_pod.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use Test::More; 4 | 5 | eval "use Test::Pod::Coverage tests => 1"; 6 | plan skip_all => "Test::Pod::Covarage required for testing POD Coverage" if $@; 7 | pod_coverage_ok ("Text::OutputFilter", "Text::OutputFilter is covered"); 8 | -------------------------------------------------------------------------------- /sandbox/leaktest: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | PERL=$1 4 | HRNS=$2 5 | shift ; shift 6 | 7 | export PERL_DL_NONLAZY=1 8 | export PERL_DESTRUCT_LEVEL=2 9 | 10 | for t in $@ ; do 11 | echo $PERL $t 12 | $PERL -MExtUtils::Command::MM -e "$HRNS" -MTest::Valgrind $t 13 | done 14 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | Changes 2 | MANIFEST 3 | Makefile.PL 4 | OutputFilter.pm 5 | README 6 | cpanfile 7 | CONTRIBUTING.md 8 | SECURITY.md 9 | t/00_pod.t 10 | t/01_pod.t 11 | t/20_margin.t 12 | t/40_comma.t 13 | t/50_sub.t 14 | t/60_filter.t 15 | t/70_misc.t 16 | t/80_error.t 17 | examples/box.pl 18 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | \.git 2 | \.tgz$ 3 | \.tar\.gz$ 4 | \.releaserc 5 | \.travis.yml 6 | \.whitesource 7 | \.tmp$ 8 | blib/ 9 | doc/ 10 | cover_db/ 11 | sandbox/ 12 | Makefile 13 | MANIFEST.SKIP 14 | META.json 15 | META.yml 16 | MYMETA.json 17 | MYMETA.yml 18 | pm_to_blib 19 | \.aspell\.local\.pws 20 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | requires "Carp"; 2 | 3 | on "configure" => sub { 4 | requires "ExtUtils::MakeMaker"; 5 | 6 | recommends "ExtUtils::MakeMaker" => "7.72"; 7 | }; 8 | 9 | on "test" => sub { 10 | requires "Test::More"; 11 | requires "Test::NoWarnings"; 12 | 13 | recommends "Test::More" => "1.302209"; 14 | }; 15 | -------------------------------------------------------------------------------- /.releaserc: -------------------------------------------------------------------------------- 1 | cpan_user HMBRAND 2 | automated_testing 1 3 | skip_kwalitee 1 4 | skip_manifest 1 5 | skip_prereqs 1 6 | skip_changes 1 7 | skip_dist 1 8 | ignore_untracked 1 9 | allow_glob_in_perls 1 10 | perls /pro/bin/perl\ 11 | :/usr/bin/perl\ 12 | :/media/Tux/perls/bin/perl5.8.*\ 13 | :/media/Tux/perls/bin/perl5.[1234][02468]*\ 14 | :/media/Tux/perls/bin/perl5.41*\ 15 | :/media/Tux/perls/bin/tperl5.8.*\ 16 | :/media/Tux/perls/bin/tperl5.[1234][02468]*\ 17 | :/media/Tux/perls/bin/tperl5.41* 18 | -------------------------------------------------------------------------------- /examples/box.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Text::OutputFilter; 7 | 8 | my $width = $ENV{COLUMNS} || 80; 9 | $width--; 10 | $width < 5 and die "Width should be > 4\n"; 11 | my $txtw = $width - 4; 12 | my $txtfmt = "# %-${txtw}.${txtw}s #"; 13 | 14 | print "#" x $width, "\n"; 15 | 16 | tie *STDOUT, "Text::OutputFilter", 0, *STDOUT, sub { 17 | sprintf $txtfmt, $_[0]; 18 | }; 19 | 20 | print <>; 21 | close STDOUT; 22 | 23 | untie *STDOUT; 24 | print "#" x $width, "\n"; 25 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | os: 3 | - linux 4 | dist: trusty 5 | perl: 6 | - "5.30" 7 | - "5.28" 8 | - "5.26" 9 | - "5.26-shrplib" 10 | - "5.24" 11 | - "5.22" 12 | - "5.20" 13 | - "5.18" 14 | - "5.16" 15 | - "5.14" 16 | - "5.12" 17 | - "5.10" 18 | - "5.8" 19 | env: 20 | global: 21 | - AUTOMATED_TESTING=1 22 | install: 23 | - cpanm --quiet --installdeps --with-all-features --notest . || true 24 | notifications: 25 | irc: 26 | channels: 27 | - "irc.perl.org#csv" 28 | on_success: always 29 | on_failure: always 30 | -------------------------------------------------------------------------------- /t/60_filter.t: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 3; 7 | use Test::NoWarnings; 8 | 9 | use_ok "Text::OutputFilter"; 10 | 11 | my $lm = 4; 12 | @ARGV and $ARGV[0] =~ m/^\d+$/ && ! -f $ARGV[0] and $lm = 0 + shift; 13 | 14 | my $buf = ""; 15 | my $expect; 16 | 17 | # Test *Filter* funtionality 18 | tie *STDOUT, "Text::OutputFilter", 1, \$buf, 19 | sub { $_[0] =~ m/\blike\b/ ? undef : ":$_[0]\$" }; 20 | 21 | $expect = " :I\$\n :do\$\n :filtering\$\n"; 22 | print "I\ndo\nlike\nfiltering\n"; 23 | is ($buf, $expect, "single arg with newline, line 1"); 24 | 25 | untie *STDOUT; 26 | -------------------------------------------------------------------------------- /t/40_comma.t: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 9; 7 | use Test::NoWarnings; 8 | 9 | use_ok "Text::OutputFilter"; 10 | 11 | my $lm = 4; 12 | @ARGV and $ARGV[0] =~ m/^\d+$/ && ! -f $ARGV[0] and $lm = 0 + shift; 13 | 14 | my $buf = ""; 15 | my $expect; 16 | 17 | local $, = "+"; 18 | ok (1, "Now with \$, set to '$,'"); 19 | $buf = ""; 20 | tie *STDOUT, "Text::OutputFilter", $lm, \$buf; 21 | 22 | $expect = " I\n"; 23 | print "I\n"; 24 | is ($buf, $expect, "single arg with newline, line 1"); 25 | 26 | $expect .= " am\n"; 27 | print "am\n"; 28 | is ($buf, $expect, "single arg with newline, line 2"); 29 | 30 | $expect .= " I+am+\n"; 31 | print "I", "am", "\n"; 32 | is ($buf, $expect, "three args with newline"); 33 | 34 | print "I"; 35 | is ($buf, $expect, "one arg, no newline"); 36 | print "am", "me"; 37 | is ($buf, $expect, "two args, no newline"); 38 | 39 | $expect .= " Iam+me"; 40 | close STDOUT; 41 | is ($buf, $expect, "closed"); 42 | 43 | untie *STDOUT; 44 | -------------------------------------------------------------------------------- /t/50_sub.t: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 9; 7 | use Test::NoWarnings; 8 | 9 | use_ok "Text::OutputFilter"; 10 | 11 | my $lm = 4; 12 | @ARGV and $ARGV[0] =~ m/^\d+$/ && ! -f $ARGV[0] and $lm = 0 + shift; 13 | 14 | my $buf = ""; 15 | my $expect; 16 | 17 | local $, = "+"; 18 | ok (1, "Now with \$, set to '$,'"); 19 | $buf = ""; 20 | tie *STDOUT, "Text::OutputFilter", $lm, \$buf, sub { ":$_[0]\$" }; 21 | 22 | $expect = " :I\$\n"; 23 | print "I\n"; 24 | is ($buf, $expect, "single arg with newline, line 1"); 25 | 26 | $expect .= " :am\$\n"; 27 | print "am\n"; 28 | is ($buf, $expect, "single arg with newline, line 2"); 29 | 30 | $expect .= " :I+am+\$\n"; 31 | print "I", "am", "\n"; 32 | is ($buf, $expect, "three args with newline"); 33 | 34 | print "I"; 35 | is ($buf, $expect, "one arg, no newline"); 36 | print "am", "me"; 37 | is ($buf, $expect, "two args, no newline"); 38 | 39 | $expect .= " :Iam+me\$"; 40 | close STDOUT; 41 | is ($buf, $expect, "closed"); 42 | 43 | untie *STDOUT; 44 | -------------------------------------------------------------------------------- /t/20_margin.t: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 10; 7 | use Test::NoWarnings; 8 | 9 | use_ok "Text::OutputFilter"; 10 | 11 | my $lm = 4; 12 | @ARGV and $ARGV[0] =~ m/^\d+$/ && ! -f $ARGV[0] and $lm = 0 + shift; 13 | 14 | my $buf = ""; 15 | tie *STDOUT, "Text::OutputFilter", $lm, \$buf; 16 | 17 | my $expect = ""; 18 | 19 | $expect = " I\n"; 20 | my $e = print "I\n"; 21 | is ($buf, $expect, "single arg with newline, line 1"); 22 | is ($e, 1, "print returned true"); 23 | 24 | $expect .= " am\n"; 25 | print "am\n"; 26 | is ($buf, $expect, "single arg with newline, line 2"); 27 | 28 | $expect .= " Iam\n"; 29 | print "I", "am", "\n"; 30 | is ($buf, $expect, "three args with newline"); 31 | 32 | print "I"; 33 | is ($buf, $expect, "one arg, no newline"); 34 | print "am", "me"; 35 | is ($buf, $expect, "two args, no newline"); 36 | 37 | $expect .= " Iamme"; 38 | 39 | sub foo { 40 | print "-foo-"; 41 | } # foo 42 | ok (foo (), "Print returns true in function call"); 43 | $expect .= "-foo-"; 44 | 45 | close STDOUT; 46 | is ($buf, $expect, "closed"); 47 | 48 | untie *STDOUT; 49 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # General 2 | 3 | I am always open to improvements and suggestions. 4 | Use [issues](https://github.com/Tux/Text-OutputFilter/issues) 5 | 6 | # Style 7 | 8 | I will never accept pull request that do not strictly conform to my 9 | style, however you might hate it. You can read the reasoning behind 10 | my [preferences](http://tux.nl/style.html). 11 | 12 | I really do not care about mixed spaces and tabs in (leading) whitespace 13 | 14 | Perl::Tidy will help getting the code in shape, but as all software, it 15 | is not perfect. You can find my preferences for these in 16 | [.perltidy](https://github.com/Tux/Release-Checklist/blob/master/.perltidyrc) and 17 | [.perlcritic](https://github.com/Tux/Release-Checklist/blob/master/.perlcriticrc). 18 | 19 | # Mail 20 | 21 | Please, please, please, do *NOT* use HTML mail. 22 | [Plain text](https://useplaintext.email) 23 | [without](http://www.goldmark.org/jeff/stupid-disclaimers/) 24 | [disclaimers](https://www.economist.com/business/2011/04/07/spare-us-the-e-mail-yada-yada) 25 | will do fine! 26 | 27 | # Requirements 28 | 29 | The minimum version required to use this module is stated in 30 | [Makefile.PL](./Makefile.PL) 31 | -------------------------------------------------------------------------------- /t/70_misc.t: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 13; 7 | use Test::NoWarnings; 8 | 9 | use_ok "Text::OutputFilter"; 10 | 11 | my $lm = 4; 12 | @ARGV and $ARGV[0] =~ m/^\d+$/ && ! -f $ARGV[0] and $lm = 0 + shift; 13 | 14 | my $buf = ""; 15 | my $expect; 16 | 17 | # Test printf () 18 | tie *STDOUT, "Text::OutputFilter", 1, \$buf, sub { "[$_[0]]" }; 19 | $expect = " [000042]\n"; 20 | my $r = printf "%06d\n", 42; 21 | untie *STDOUT; 22 | is ($buf, $expect, "printf ()"); 23 | is ($r, 1, "printf returned true"); 24 | 25 | # test binmode, tell, fileno, and eof 26 | $buf = ""; 27 | local $\ = ""; 28 | tie *STDOUT, "Text::OutputFilter", 1, \$buf, sub { "[$_[0]]" }; 29 | is (binmode (STDOUT, ":crlf"), 1, "binmode :crlf"); 30 | $expect = " [000042]\r\n"; 31 | printf "%06d\n", 42; 32 | # ----+----1+ 33 | is (tell STDOUT, 11, "tell ()"); 34 | # Tied to a scalar: should return -1 35 | is (fileno STDOUT, -1, "fileno ()"); 36 | is (eof STDOUT, 0, "eof ()"); 37 | is (binmode (STDOUT), 1, "binmode ()"); 38 | is ($buf, $expect, "printf ()"); 39 | is (close STDOUT, 1, "close ()"); 40 | untie *STDOUT; 41 | 42 | # test forbidden and NYI 43 | tie *STDOUT, "Text::OutputFilter", 1, \$buf, sub { "[$_[0]]" }; 44 | eval { my $in = }; 45 | like ($@, qr{No support for \S+ method}, "output only"); 46 | eval { seek STDOUT, 5, 0 }; 47 | like ($@, qr{Support for \S+ method NYI}, "NYI"); 48 | untie *STDOUT; 49 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | Text::OutputFilter - Filter and modify output 4 | 5 | =head1 SYNOPSIS 6 | 7 | use Text::OutputFilter; 8 | 9 | my $bucket = ""; 10 | tie *STDOUT, "Text::OutputFilter"; 11 | tie *HANDLE, "Text::OutputFilter", 4; 12 | tie *HANDLE, "Text::OutputFilter", 4, *STDOUT; 13 | tie *STDOUT, "Text::OutputFilter", 4, \$bucket; 14 | tie *OUTPUT, "Text::OutputFilter", 4, *STDOUT, sub { "$_[0]" }; 15 | 16 | =head1 DESCRIPTION 17 | 18 | See C or C. 19 | 20 | =head1 INSTALLATION 21 | 22 | $ perl Makefile.PL 23 | $ make 24 | $ make test 25 | $ make install 26 | 27 | Recent changes can be (re)viewed in the public GIT repository at 28 | https://github.com/Tux/Text-OutputFilter 29 | 30 | Feel free to clone your own copy: 31 | 32 | $ git clone https://github.com/Tux/Text-OutputFilter Text-OutputFilter 33 | 34 | or get it as a tgz: 35 | 36 | $ wget --output-document=Text-OutputFilter-git.tgz \ 37 | https://github.com/Tux/Text-OutputFilter/archive/master.tar.gz 38 | 39 | =head1 BUGS & TODO 40 | 41 | =over 4 42 | 43 | =item format 44 | 45 | Output from format/write is not caught. This seems to be a bug in 46 | perl itself, and is unlikely to be fixed by this module. 47 | 48 | =item examples 49 | 50 | There should be example files with both input and output shown. 51 | 52 | =back 53 | 54 | =head1 AUTHOR 55 | 56 | H.Merijn Brand 57 | 58 | =head1 COPYRIGHT AND LICENSE 59 | 60 | Copyright (C) 2006-2025 H.Merijn Brand for PROCURA B.V. 61 | 62 | This library is free software; you can redistribute it and/or modify 63 | it under the same terms as Perl itself. 64 | 65 | =cut 66 | -------------------------------------------------------------------------------- /sandbox/genMETA.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Getopt::Long qw(:config bundling nopermute); 7 | GetOptions ( 8 | "c|check" => \ my $check, 9 | "u|update!" => \ my $update, 10 | "v|verbose:1" => \(my $opt_v = 0), 11 | ) or die "usage: $0 [--check]\n"; 12 | 13 | use lib "sandbox"; 14 | use genMETA; 15 | my $meta = genMETA->new ( 16 | from => "OutputFilter.pm", 17 | verbose => $opt_v, 18 | ); 19 | 20 | $meta->from_data (); 21 | $meta->security_md ($update); 22 | $meta->gen_cpanfile (); 23 | 24 | if ($check) { 25 | $meta->check_encoding (); 26 | $meta->check_required (); 27 | $meta->check_minimum ([ "t", "examples", "OutputFilter.pm", "Makefile.PL" ]); 28 | $meta->done_testing (); 29 | } 30 | elsif ($opt_v) { 31 | $meta->print_yaml (); 32 | } 33 | else { 34 | $meta->fix_meta (); 35 | } 36 | 37 | __END__ 38 | --- #YAML:1.0 39 | name: Text-OutputFilter 40 | version: VERSION 41 | abstract: Filter and modify output 42 | license: perl 43 | author: 44 | - H.Merijn Brand 45 | generated_by: Author 46 | distribution_type: module 47 | provides: 48 | Text::OutputFilter: 49 | file: OutputFilter.pm 50 | version: VERSION 51 | requires: 52 | perl: 5.008 53 | Carp: 0 54 | configure_requires: 55 | ExtUtils::MakeMaker: 0 56 | configure_recommends: 57 | ExtUtils::MakeMaker: 7.72 58 | test_requires: 59 | Test::More: 0 60 | Test::NoWarnings: 0 61 | test_recommends: 62 | Test::More: 1.302209 63 | resources: 64 | license: http://dev.perl.org/licenses/ 65 | repository: https://github.com/Tux/Text-OutputFilter 66 | bugtracker: https://github.com/Tux/Text-OutputFilter/issues 67 | meta-spec: 68 | version: 1.4 69 | url: http://module-build.sourceforge.net/META-spec-v1.4.html 70 | -------------------------------------------------------------------------------- /doc/OutputFilter.md: -------------------------------------------------------------------------------- 1 | # NAME 2 | 3 | OutputFilter - Enable post processing of output without fork 4 | 5 | # SYNOPSIS 6 | 7 | use Text::OutputFilter; 8 | 9 | my $bucket = ""; 10 | tie *STDOUT, "Text::OutputFilter"; 11 | tie *HANDLE, "Text::OutputFilter", 4; 12 | tie *HANDLE, "Text::OutputFilter", 4, *STDOUT; 13 | tie *STDOUT, "Text::OutputFilter", 4, \$bucket; 14 | tie *OUTPUT, "Text::OutputFilter", 4, *STDOUT, sub { "$_[0]" }; 15 | 16 | # DESCRIPTION 17 | 18 | This interface enables some post-processing on output streams, 19 | like adding a left margin. 20 | 21 | The tied filehandle is opened unbuffered, but the output is line 22 | buffered. The `tie` takes three optional arguments: 23 | 24 | - Left Margin 25 | 26 | The left margin must be a positive integer and defaults to `4` spaces. 27 | 28 | - Output Stream 29 | 30 | The output stream must be an already open stream, with writing 31 | enabled. The default is `*STDOUT`. All input methods on the new 32 | stream are disabled. If a reference to a scalar is passed, it will 33 | be opened as PerlIO::scalar - in-memory IO, scalar IO. No checks 34 | performed to see if your perl supports it. If you want it, and your 35 | perl does not, upgrade. 36 | 37 | Using `binmode ()` on the new stream is allowed and supported. 38 | 39 | OPEN, SEEK, and WRITE are not (yet) implemented. 40 | 41 | - Line Modifying Function 42 | 43 | The output is line buffered, to enable line-modifier functions. 44 | The line (without newline) is passed as the only argument to the 45 | sub-ref, whose output is printed after the prefix from the first 46 | argument. A newline is printed after the sub-ref's output. 47 | 48 | To **filter** a line, as in _remove_ it from the stream, make the 49 | sub return _undef_. 50 | 51 | # TODO 52 | 53 | Tests, tests, tests. 54 | Tests with older perls 55 | 56 | # AUTHOR 57 | 58 | H.Merijn Brand 59 | 60 | # COPYRIGHT AND LICENSE 61 | 62 | Copyright (C) 2006-2025 H.Merijn Brand for PROCURA B.V. 63 | 64 | This library is free software; you can redistribute it and/or modify 65 | it under the same terms as Perl itself. 66 | 67 | # SEE ALSO 68 | 69 | perl(1), perlopen(1), 'open STDOUT, "|-"', Text::Filter 70 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright PROCURA B.V. (c) 2006-2025 H.Merijn Brand 4 | 5 | require 5.008; 6 | use strict; 7 | 8 | use ExtUtils::MakeMaker; 9 | 10 | my %wm = ( 11 | NAME => "Text::OutputFilter", 12 | DISTNAME => "Text-OutputFilter", 13 | ABSTRACT => "Filter and modify output", 14 | AUTHOR => "H.Merijn Brand ", 15 | LICENSE => "perl", 16 | VERSION_FROM => "OutputFilter.pm", 17 | PREREQ_PM => { "Carp" => 0, 18 | "Test::More" => 0, 19 | "Test::NoWarnings" => 0, 20 | }, 21 | macro => { TARFLAGS => "--format=ustar -c -v -f", 22 | }, 23 | ); 24 | 25 | my $rv = WriteMakefile (%wm); 26 | 27 | 1; 28 | 29 | package MY; 30 | 31 | sub postamble { 32 | my $valgrind = join " ", qw( 33 | PERL_DESTRUCT_LEVEL=2 PERL_DL_NONLAZY=1 34 | valgrind 35 | --suppressions=sandbox/perl.supp 36 | --leak-check=yes 37 | --leak-resolution=high 38 | --show-reachable=yes 39 | --num-callers=50 40 | --log-fd=3 41 | $(FULLPERLRUN) "-MExtUtils::Command::MM" "-e" 42 | "test_harness($(TEST_VERBOSE), '$(INST_LIB)', '$(INST_ARCHLIB)')" 43 | $(TEST_FILES) 3>valgrind.log 44 | ); 45 | join "\n" => 46 | 'cover test_cover:', 47 | ' ccache -C', 48 | ' cover -test', 49 | '', 50 | 'leakcheck:', 51 | " $valgrind", 52 | ' -@tail -5 valgrind.log', 53 | '', 54 | 'leaktest:', 55 | q{ sandbox/leaktest $(FULLPERLRUN) "test_harness($(TEST_VERBOSE), '$(INST_LIB)', '$(INST_ARCHLIB)')" $(TEST_FILES)}, 56 | '', 57 | 'spellcheck: doc', 58 | ' pod-spell-check --aspell', 59 | '', 60 | 'checkmeta: spellcheck', 61 | ' perl sandbox/genMETA.pl -c', 62 | '', 63 | 'fixmeta: distmeta', 64 | ' perl sandbox/genMETA.pl', 65 | '', 66 | 'tgzdist: checkmeta fixmeta $(DISTVNAME).tar.gz distcheck', 67 | ' -@mv -f $(DISTVNAME).tar.gz $(DISTVNAME).tgz', 68 | ' -@cpants_lint.pl $(DISTVNAME).tgz', 69 | ' -@rm -f Debian_CPANTS.txt', 70 | '', 71 | 'doc docs: doc/OutputFilter.md doc/OutputFilter.html doc/OutputFilter.man', 72 | ' -@rm -f pod2html.tmp', 73 | 'doc/OutputFilter.md: OutputFilter.pm', 74 | ' pod2markdown < $? > $@', 75 | 'doc/OutputFilter.html: OutputFilter.pm', 76 | ' pod2html < $? 2>&1 | grep -v "^Cannot find" > $@', 77 | 'doc/OutputFilter.3: OutputFilter.pm', 78 | ' pod2man < $? > $@', 79 | 'doc/OutputFilter.man: doc/OutputFilter.3', 80 | ' nroff2man < $? > $@', 81 | ''; 82 | } # postamble 83 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | 0.26 - 17 Mar 2025, H.Merijn Brand 2 | * Fix static doc for groff-1.24 fail 3 | * It is 2024 4 | * Tested with perl-5.40 5 | * It is 2025 6 | 7 | 0.25 - 06 Jan 2023, H.Merijn Brand 8 | * It is 2023 9 | 10 | 0.24 - 01 Jan 2022, H.Merijn Brand 11 | * It is 2021 - No changes in 2021 12 | * It is 2022 13 | 14 | 0.23 - 21 Dec 2020, H.Merijn Brand 15 | * Fix META issue for bugtracker 16 | 17 | 0.22 - 09 Apr 2020, H.Merijn Brand 18 | * Provide cpanfile 19 | * It is 2020 20 | 21 | 0.21 - 23 Apr 2019, H.Merijn Brand 22 | * It is 2017 23 | * It is 2018 24 | * It is 2019 25 | * Make PRINT return as print would (issue #1) 26 | 27 | 0.20 - 12 May 2016, H.Merijn Brand 28 | * Add CONTRIBUTING.md 29 | * Do not print undefined lines on close 30 | * It is 2016 31 | * Tested with pperl 5.24.0 32 | 33 | 0.19 - 11 Feb 2015, H.Merijn Brand 34 | * Upped copyright to 2015 35 | * Move repo to github 36 | * Remove perl recommendation from META as it breaks cpan clients 37 | 38 | 0.18 - 07 Feb 2014, H.Merijn Brand 39 | * Upped copyright to 2012 40 | * Upped copyright to 2013 41 | * Upped copyright to 2014 42 | * Updated META specs to Lancaster consensus (administrative release) 43 | 44 | 0.17 - 07 Sep 2011, H.Merijn Brand 45 | * NAME / DISTNAME in Makefile.PL 46 | 47 | 0.16 - 07 Sep 2011, H.Merijn Brand 48 | * Spell checks 49 | * More cross-checks for META data 50 | * Upped copyright to 2011 51 | 52 | 0.15 - 16 Mar 2010, H.Merijn Brand 53 | * Added Test::NoWarnings 54 | * Dropped YAML spec to 1.0 55 | * Upped copyright to 2010 56 | 57 | 0.14 - 07 Jan 2009, H.Merijn Brand 58 | * Copyright 2009 59 | * Made the license as in perl. Was still accidentally restricted 60 | * Corrected e-mail 61 | * Generated and checked META.yml 62 | 63 | 0.13 - 02 Jan 2008, H.Merijn Brand 64 | * Spellchecks 65 | * Removed prototypes 66 | * Now under git 67 | * Added simplistic example 68 | * Added prereq's to Makefile.PL 69 | * Upped copyright year 70 | 71 | 0.12 - 02 May 2007, H.Merijn Brand 72 | * Pod checks were wrong (yank/put problem) 73 | * Added test_cover make target 74 | * Added Text::Filter to SEE ALSO 75 | * Added tests for printf and binmode 76 | * Fixed binmode 77 | * Added tests for tell, eof, and fileno 78 | * Added tests for input (forbidden) and NYI functionality 79 | 80 | 0.11 - 21 Mar 2007, H.Merijn Brand 81 | * Initial release to CPAN 82 | -------------------------------------------------------------------------------- /doc/OutputFilter.man: -------------------------------------------------------------------------------- 1 | STDIN(1) User Contributed Perl Documentation STDIN(1) 2 | 3 | NAME 4 | OutputFilter - Enable post processing of output without fork 5 | 6 | SYNOPSIS 7 | use Text::OutputFilter; 8 | 9 | my $bucket = ""; 10 | tie *STDOUT, "Text::OutputFilter"; 11 | tie *HANDLE, "Text::OutputFilter", 4; 12 | tie *HANDLE, "Text::OutputFilter", 4, *STDOUT; 13 | tie *STDOUT, "Text::OutputFilter", 4, \$bucket; 14 | tie *OUTPUT, "Text::OutputFilter", 4, *STDOUT, sub { "$_[0]" }; 15 | 16 | DESCRIPTION 17 | This interface enables some post-processing on output streams, like 18 | adding a left margin. 19 | 20 | The tied filehandle is opened unbuffered, but the output is line 21 | buffered. The "tie" takes three optional arguments: 22 | 23 | Left Margin 24 | The left margin must be a positive integer and defaults to 4 25 | spaces. 26 | 27 | Output Stream 28 | The output stream must be an already open stream, with writing 29 | enabled. The default is *STDOUT. All input methods on the new 30 | stream are disabled. If a reference to a scalar is passed, it will 31 | be opened as PerlIO::scalar - in-memory IO, scalar IO. No checks 32 | performed to see if your perl supports it. If you want it, and your 33 | perl does not, upgrade. 34 | 35 | Using "binmode ()" on the new stream is allowed and supported. 36 | 37 | OPEN, SEEK, and WRITE are not (yet) implemented. 38 | 39 | Line Modifying Function 40 | The output is line buffered, to enable line-modifier functions. 41 | The line (without newline) is passed as the only argument to the 42 | sub-ref, whose output is printed after the prefix from the first 43 | argument. A newline is printed after the sub-ref's output. 44 | 45 | To filter a line, as in remove it from the stream, make the sub 46 | return undef. 47 | 48 | TODO 49 | Tests, tests, tests. Tests with older perls 50 | 51 | AUTHOR 52 | H.Merijn Brand 53 | 54 | COPYRIGHT AND LICENSE 55 | Copyright (C) 2006-2025 H.Merijn Brand for PROCURA B.V. 56 | 57 | This library is free software; you can redistribute it and/or modify it 58 | under the same terms as Perl itself. 59 | 60 | SEE ALSO 61 | perl(1), perlopen(1), 'open STDOUT, "|-"', Text::Filter 62 | 63 | perl v5.40.1 2025-03-17 STDIN(1) 64 | -------------------------------------------------------------------------------- /doc/OutputFilter.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | OutputFilter - Enable post processing of output without fork 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 23 | 24 |

NAME

25 | 26 |

OutputFilter - Enable post processing of output without fork

27 | 28 |

SYNOPSIS

29 | 30 | 
use Text::OutputFilter;
31 | 
32 | my $bucket = "";
33 | tie *STDOUT, "Text::OutputFilter";
34 | tie *HANDLE, "Text::OutputFilter", 4;
35 | tie *HANDLE, "Text::OutputFilter", 4,  *STDOUT;
36 | tie *STDOUT, "Text::OutputFilter", 4, \$bucket;
37 | tie *OUTPUT, "Text::OutputFilter", 4,  *STDOUT, sub { "$_[0]" };
38 | 39 |

DESCRIPTION

40 | 41 |

This interface enables some post-processing on output streams, like adding a left margin.

42 | 43 |

The tied filehandle is opened unbuffered, but the output is line buffered. The tie takes three optional arguments:

44 | 45 |
46 | 47 |
Left Margin
48 |
49 | 50 |

The left margin must be a positive integer and defaults to 4 spaces.

51 | 52 |
53 |
Output Stream
54 |
55 | 56 |

The output stream must be an already open stream, with writing enabled. The default is *STDOUT. All input methods on the new stream are disabled. If a reference to a scalar is passed, it will be opened as PerlIO::scalar - in-memory IO, scalar IO. No checks performed to see if your perl supports it. If you want it, and your perl does not, upgrade.

57 | 58 |

Using binmode () on the new stream is allowed and supported.

59 | 60 |

OPEN, SEEK, and WRITE are not (yet) implemented.

61 | 62 |
63 |
Line Modifying Function
64 |
65 | 66 |

The output is line buffered, to enable line-modifier functions. The line (without newline) is passed as the only argument to the sub-ref, whose output is printed after the prefix from the first argument. A newline is printed after the sub-ref's output.

67 | 68 |

To filter a line, as in remove it from the stream, make the sub return undef.

69 | 70 |
71 |
72 | 73 |

TODO

74 | 75 |

Tests, tests, tests. Tests with older perls

76 | 77 |

AUTHOR

78 | 79 |

H.Merijn Brand <h.m.brand@procura.nl>

80 | 81 |

COPYRIGHT AND LICENSE

82 | 83 |

Copyright (C) 2006-2025 H.Merijn Brand for PROCURA B.V.

84 | 85 |

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

86 | 87 |

SEE ALSO

88 | 89 |

perl(1), perlopen(1), 'open STDOUT, "|-"', Text::Filter

90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | -------------------------------------------------------------------------------- /t/80_error.t: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 44; 7 | use Test::NoWarnings; 8 | 9 | use_ok "Text::OutputFilter"; 10 | 11 | my $lm = 4; 12 | @ARGV and $ARGV[0] =~ m/^\d+$/ && ! -f $ARGV[0] and $lm = 0 + shift; 13 | 14 | my $buf = ""; 15 | my $expect; 16 | 17 | my $tof = "Text::OutputFilter"; 18 | tie *STDOUT, $tof, undef, \$buf; 19 | like (tied (*STDOUT), qr{^$tof=HASH}, "lm = undef - tied"); 20 | untie *STDOUT; 21 | is (tied (*STDOUT), undef, "lm = undef - untied"); 22 | 23 | tie *STDOUT, $tof, 0, \$buf; 24 | like (tied (*STDOUT), qr{^$tof=HASH}, "lm = 0 - tied"); 25 | untie *STDOUT; 26 | is (tied (*STDOUT), undef, "lm = 0 - untied"); 27 | 28 | eval { tie *STDOUT, $tof, undef, *STDERR }; 29 | like (tied (*STDOUT), qr{^$tof=HASH}, "lm = 0 - tied"); 30 | untie *STDOUT; 31 | is (tied (*STDOUT), undef, "lm = 0 - untied"); 32 | 33 | # test errors 34 | eval { tie *STDOUT, $tof, "x", \$buf }; 35 | is (tied (*STDOUT), undef, "lm = 'x' - fail"); 36 | like ($@, qr{1st arg must be numeric}, "lm must be numeric"); 37 | 38 | eval { tie *STDOUT, $tof, [ ], \$buf }; 39 | is (tied (*STDOUT), undef, "lm = [] - fail"); 40 | like ($@, qr{1st arg must be numeric}, "lm must be numeric"); 41 | 42 | eval { tie *STDOUT, $tof, { }, \$buf }; 43 | is (tied (*STDOUT), undef, "lm = {} - fail"); 44 | like ($@, qr{1st arg must be numeric}, "lm must be numeric"); 45 | 46 | eval { tie *STDOUT, $tof, undef, [ ] }; 47 | is (tied (*STDOUT), undef, "io = [] - fail"); 48 | like ($@, qr{2nd arg must be the output handle}, "io must be handle"); 49 | 50 | eval { tie *STDOUT, $tof, undef, { } }; 51 | is (tied (*STDOUT), undef, "io = {} - fail"); 52 | like ($@, qr{2nd arg must be the output handle}, "io must be handle"); 53 | 54 | eval { local *FOO; tie *STDOUT, $tof, undef, *FOO }; 55 | is (tied (*STDOUT), undef, "io = *FOO undef - fail"); 56 | like ($@, qr{2nd arg must be the output handle}, "io must be handle"); 57 | 58 | eval { local *FOO; tie *STDOUT, $tof, undef, \*FOO }; 59 | is (tied (*STDOUT), undef, "io = \\*FOO undef - fail"); 60 | like ($@, qr{2nd arg must be the output handle}, "io must be handle"); 61 | 62 | eval { my $foo; local *FOO; open FOO, ">", \$foo; tie *STDOUT, $tof, undef, *FOO }; 63 | is (tied (*STDOUT), undef, "io = *FOO -> \\\$foo - fail"); 64 | like ($@, qr{2nd arg must be the output handle}, "io must be handle"); 65 | 66 | eval { tie *STDOUT, $tof, undef, undef, 0 }; 67 | is (tied (*STDOUT), undef, "sub = 0 - fail"); 68 | like ($@, qr{3rd arg must be CODE-ref}, "sub must be CODE"); 69 | 70 | eval { tie *STDOUT, $tof, undef, undef, "x" }; 71 | is (tied (*STDOUT), undef, "sub = 'x' - fail"); 72 | like ($@, qr{3rd arg must be CODE-ref}, "sub must be CODE"); 73 | 74 | eval { tie *STDOUT, $tof, undef, undef, [ ] }; 75 | is (tied (*STDOUT), undef, "sub = [] - fail"); 76 | like ($@, qr{3rd arg must be CODE-ref}, "sub must be CODE"); 77 | 78 | eval { tie *STDOUT, $tof, undef, undef, { } }; 79 | is (tied (*STDOUT), undef, "sub = {} - fail"); 80 | like ($@, qr{3rd arg must be CODE-ref}, "sub must be CODE"); 81 | 82 | eval { local *FOO; tie *STDOUT, $tof, undef, undef, *FOO }; 83 | is (tied (*STDOUT), undef, "sub = *FOO - fail"); 84 | like ($@, qr{3rd arg must be CODE-ref}, "sub must be CODE"); 85 | 86 | tie *STDOUT, $tof, undef, \$buf; 87 | like (tied (*STDOUT), qr{^$tof=HASH}, "methods on closed handle"); 88 | is (close STDOUT, 1, "close ()"); 89 | is (eof STDOUT, 1, "closed"); 90 | is (close STDOUT, 1, "close () again"); 91 | 92 | eval { binmode STDOUT }; 93 | like ($@, qr{Cannot set binmode on closed}, "binmode on closed"); 94 | eval { print STDOUT "\n" }; 95 | like ($@, qr{Cannot print to closed}, "print to closed"); 96 | eval { printf STDOUT "\n" }; 97 | like ($@, qr{Cannot print to closed}, "printf to closed"); 98 | eval { my $pos = tell STDOUT }; 99 | like ($@, qr{Cannot tell from a closed}, "tell from closed"); 100 | untie *STDOUT; 101 | 102 | tie *STDOUT, $tof, undef, \$buf; 103 | like (tied (*STDOUT), qr{^$tof=HASH}, "undef the FH"); 104 | undef *STDOUT; 105 | is (tied (*STDOUT), undef, "untied"); 106 | -------------------------------------------------------------------------------- /doc/OutputFilter.3: -------------------------------------------------------------------------------- 1 | .\" -*- mode: troff; coding: utf-8 -*- 2 | .\" Automatically generated by Pod::Man v6.0.2 (Pod::Simple 3.45) 3 | .\" 4 | .\" Standard preamble: 5 | .\" ======================================================================== 6 | .de Sp \" Vertical space (when we can't use .PP) 7 | .if t .sp .5v 8 | .if n .sp 9 | .. 10 | .de Vb \" Begin verbatim text 11 | .ft CW 12 | .nf 13 | .ne \\$1 14 | .. 15 | .de Ve \" End verbatim text 16 | .ft R 17 | .fi 18 | .. 19 | .\" \*(C` and \*(C' are quotes in nroff, nothing in troff, for use with C<>. 20 | .ie n \{\ 21 | . ds C` "" 22 | . ds C' "" 23 | 'br\} 24 | .el\{\ 25 | . ds C` 26 | . ds C' 27 | 'br\} 28 | .\" 29 | .\" Escape single quotes in literal strings from groff's Unicode transform. 30 | .ie \n(.g .ds Aq \(aq 31 | .el .ds Aq ' 32 | .\" 33 | .\" If the F register is >0, we'll generate index entries on stderr for 34 | .\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index 35 | .\" entries marked with X<> in POD. Of course, you'll have to process the 36 | .\" output yourself in some meaningful fashion. 37 | .\" 38 | .\" Avoid warning from groff about undefined register 'F'. 39 | .de IX 40 | .. 41 | .nr rF 0 42 | .if \n(.g .if rF .nr rF 1 43 | .if (\n(rF:(\n(.g==0)) \{\ 44 | . if \nF \{\ 45 | . de IX 46 | . tm Index:\\$1\t\\n%\t"\\$2" 47 | .. 48 | . if !\nF==2 \{\ 49 | . nr % 0 50 | . nr F 2 51 | . \} 52 | . \} 53 | .\} 54 | .rr rF 55 | .\" 56 | .\" Required to disable full justification in groff 1.23.0. 57 | .if n .ds AD l 58 | .\" ======================================================================== 59 | .\" 60 | .IX Title "STDIN 1" 61 | .TH STDIN 1 2025-03-17 "perl v5.40.1" "User Contributed Perl Documentation" 62 | .\" For nroff, turn off justification. Always turn off hyphenation; it makes 63 | .\" way too many mistakes in technical documents. 64 | .if n .ad l 65 | .nh 66 | .SH NAME 67 | OutputFilter \- Enable post processing of output without fork 68 | .SH SYNOPSIS 69 | .IX Header "SYNOPSIS" 70 | .Vb 1 71 | \& use Text::OutputFilter; 72 | \& 73 | \& my $bucket = ""; 74 | \& tie *STDOUT, "Text::OutputFilter"; 75 | \& tie *HANDLE, "Text::OutputFilter", 4; 76 | \& tie *HANDLE, "Text::OutputFilter", 4, *STDOUT; 77 | \& tie *STDOUT, "Text::OutputFilter", 4, \e$bucket; 78 | \& tie *OUTPUT, "Text::OutputFilter", 4, *STDOUT, sub { "$_[0]" }; 79 | .Ve 80 | .SH DESCRIPTION 81 | .IX Header "DESCRIPTION" 82 | This interface enables some post\-processing on output streams, 83 | like adding a left margin. 84 | .PP 85 | The tied filehandle is opened unbuffered, but the output is line 86 | buffered. The \f(CW\*(C`tie\*(C'\fR takes three optional arguments: 87 | .IP "Left Margin" 4 88 | .IX Item "Left Margin" 89 | The left margin must be a positive integer and defaults to \f(CW4\fR spaces. 90 | .IP "Output Stream" 4 91 | .IX Item "Output Stream" 92 | The output stream must be an already open stream, with writing 93 | enabled. The default is \f(CW*STDOUT\fR. All input methods on the new 94 | stream are disabled. If a reference to a scalar is passed, it will 95 | be opened as PerlIO::scalar \- in\-memory IO, scalar IO. No checks 96 | performed to see if your perl supports it. If you want it, and your 97 | perl does not, upgrade. 98 | .Sp 99 | Using \f(CW\*(C`binmode ()\*(C'\fR on the new stream is allowed and supported. 100 | .Sp 101 | OPEN, SEEK, and WRITE are not (yet) implemented. 102 | .IP "Line Modifying Function" 4 103 | .IX Item "Line Modifying Function" 104 | The output is line buffered, to enable line\-modifier functions. 105 | The line (without newline) is passed as the only argument to the 106 | sub\-ref, whose output is printed after the prefix from the first 107 | argument. A newline is printed after the sub\-ref\*(Aqs output. 108 | .Sp 109 | To \fBfilter\fR a line, as in \fIremove\fR it from the stream, make the 110 | sub return \fIundef\fR. 111 | .SH TODO 112 | .IX Header "TODO" 113 | Tests, tests, tests. 114 | Tests with older perls 115 | .SH AUTHOR 116 | .IX Header "AUTHOR" 117 | H.Merijn Brand 118 | .SH "COPYRIGHT AND LICENSE" 119 | .IX Header "COPYRIGHT AND LICENSE" 120 | Copyright (C) 2006\-2025 H.Merijn Brand for PROCURA B.V. 121 | .PP 122 | This library is free software; you can redistribute it and/or modify 123 | it under the same terms as Perl itself. 124 | .SH "SEE ALSO" 125 | .IX Header "SEE ALSO" 126 | \&\fBperl\fR\|(1), \fBperlopen\fR\|(1), \*(Aqopen STDOUT, "|\-"\*(Aq, Text::Filter 127 | -------------------------------------------------------------------------------- /SECURITY.md: -------------------------------------------------------------------------------- 1 | # Security Policy for the Text::OutputFilter distribution. 2 | 3 | Report issues via email at: H.Merijn Brand . 4 | 5 | 6 | This is the Security Policy for Text::OutputFilter. 7 | 8 | The latest version of the Security Policy can be found in the 9 | [git repository for Text::OutputFilter](https://github.com/Tux/Text-OutputFilter). 10 | 11 | This text is based on the CPAN Security Group's Guidelines for Adding 12 | a Security Policy to Perl Distributions (version 1.0.0) 13 | https://security.metacpan.org/docs/guides/security-policy-for-authors.html 14 | 15 | # How to Report a Security Vulnerability 16 | 17 | Security vulnerabilities can be reported by e-mail to the current 18 | project maintainers at H.Merijn Brand . 19 | 20 | Please include as many details as possible, including code samples 21 | or test cases, so that we can reproduce the issue. Check that your 22 | report does not expose any sensitive data, such as passwords, 23 | tokens, or personal information. 24 | 25 | If you would like any help with triaging the issue, or if the issue 26 | is being actively exploited, please copy the report to the CPAN 27 | Security Group (CPANSec) at . 28 | 29 | Please *do not* use the public issue reporting system on RT or 30 | GitHub issues for reporting security vulnerabilities. 31 | 32 | Please do not disclose the security vulnerability in public forums 33 | until past any proposed date for public disclosure, or it has been 34 | made public by the maintainers or CPANSec. That includes patches or 35 | pull requests. 36 | 37 | For more information, see 38 | [Report a Security Issue](https://security.metacpan.org/docs/report.html) 39 | on the CPANSec website. 40 | 41 | ## Response to Reports 42 | 43 | The maintainer(s) aim to acknowledge your security report as soon as 44 | possible. However, this project is maintained by a single person in 45 | their spare time, and they cannot guarantee a rapid response. If you 46 | have not received a response from them within 10 days, then 47 | please send a reminder to them and copy the report to CPANSec at 48 | . 49 | 50 | Please note that the initial response to your report will be an 51 | acknowledgement, with a possible query for more information. It 52 | will not necessarily include any fixes for the issue. 53 | 54 | The project maintainer(s) may forward this issue to the security 55 | contacts for other projects where we believe it is relevant. This 56 | may include embedded libraries, system libraries, prerequisite 57 | modules or downstream software that uses this software. 58 | 59 | They may also forward this issue to CPANSec. 60 | 61 | # Which Software This Policy Applies To 62 | 63 | Any security vulnerabilities in Text::OutputFilter are covered by this policy. 64 | 65 | Security vulnerabilities are considered anything that allows users 66 | to execute unauthorised code, access unauthorised resources, or to 67 | have an adverse impact on accessibility or performance of a system. 68 | 69 | Security vulnerabilities in upstream software (embedded libraries, 70 | prerequisite modules or system libraries, or in Perl), are not 71 | covered by this policy unless they affect Text::OutputFilter, or Text::OutputFilter can 72 | be used to exploit vulnerabilities in them. 73 | 74 | Security vulnerabilities in downstream software (any software that 75 | uses Text::OutputFilter, or plugins to it that are not included with the 76 | Text::OutputFilter distribution) are not covered by this policy. 77 | 78 | ## Supported Versions of Text::OutputFilter 79 | 80 | The maintainer(s) will only commit to releasing security fixes for 81 | the latest version of Text::OutputFilter. 82 | 83 | Note that the Text::OutputFilter project only supports major versions of Perl 84 | released in the past 5 years, even though Text::OutputFilter will run on 85 | older versions of Perl. If a security fix requires us to increase 86 | the minimum version of Perl that is supported, then we may do so. 87 | 88 | # Installation and Usage Issues 89 | 90 | The distribution metadata specifies minimum versions of 91 | prerequisites that are required for Text::OutputFilter to work. However, some 92 | of these prerequisites may have security vulnerabilities, and you 93 | should ensure that you are using up-to-date versions of these 94 | prerequisites. 95 | 96 | Where security vulnerabilities are known, the metadata may indicate 97 | newer versions as recommended. 98 | 99 | ## Usage 100 | 101 | Please see the software documentation for further information. 102 | -------------------------------------------------------------------------------- /OutputFilter.pm: -------------------------------------------------------------------------------- 1 | package Text::OutputFilter; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | our $VERSION = "0.26"; 7 | 8 | =head1 NAME 9 | 10 | OutputFilter - Enable post processing of output without fork 11 | 12 | =head1 SYNOPSIS 13 | 14 | use Text::OutputFilter; 15 | 16 | my $bucket = ""; 17 | tie *STDOUT, "Text::OutputFilter"; 18 | tie *HANDLE, "Text::OutputFilter", 4; 19 | tie *HANDLE, "Text::OutputFilter", 4, *STDOUT; 20 | tie *STDOUT, "Text::OutputFilter", 4, \$bucket; 21 | tie *OUTPUT, "Text::OutputFilter", 4, *STDOUT, sub { "$_[0]" }; 22 | 23 | =head1 DESCRIPTION 24 | 25 | This interface enables some post-processing on output streams, 26 | like adding a left margin. 27 | 28 | The tied filehandle is opened unbuffered, but the output is line 29 | buffered. The C takes three optional arguments: 30 | 31 | =over 4 32 | 33 | =item Left Margin 34 | 35 | The left margin must be a positive integer and defaults to C<4> spaces. 36 | 37 | =item Output Stream 38 | 39 | The output stream must be an already open stream, with writing 40 | enabled. The default is C<*STDOUT>. All input methods on the new 41 | stream are disabled. If a reference to a scalar is passed, it will 42 | be opened as PerlIO::scalar - in-memory IO, scalar IO. No checks 43 | performed to see if your perl supports it. If you want it, and your 44 | perl does not, upgrade. 45 | 46 | Using C on the new stream is allowed and supported. 47 | 48 | OPEN, SEEK, and WRITE are not (yet) implemented. 49 | 50 | =item Line Modifying Function 51 | 52 | The output is line buffered, to enable line-modifier functions. 53 | The line (without newline) is passed as the only argument to the 54 | sub-ref, whose output is printed after the prefix from the first 55 | argument. A newline is printed after the sub-ref's output. 56 | 57 | To B a line, as in I it from the stream, make the 58 | sub return I. 59 | 60 | =back 61 | 62 | =head1 TODO 63 | 64 | Tests, tests, tests. 65 | Tests with older perls 66 | 67 | =head1 AUTHOR 68 | 69 | H.Merijn Brand 70 | 71 | =head1 COPYRIGHT AND LICENSE 72 | 73 | Copyright (C) 2006-2025 H.Merijn Brand for PROCURA B.V. 74 | 75 | This library is free software; you can redistribute it and/or modify 76 | it under the same terms as Perl itself. 77 | 78 | =head1 SEE ALSO 79 | 80 | perl(1), perlopen(1), 'open STDOUT, "|-"', Text::Filter 81 | 82 | =cut 83 | 84 | use Carp; 85 | 86 | sub TIEHANDLE { 87 | my ($class, $lm, $io, $ref, $fno) = @_; 88 | 89 | defined $lm or $lm = 4; 90 | defined $io or $io = *STDOUT; 91 | defined $ref or $ref = sub { shift }; 92 | 93 | ref $lm || $lm !~ m/^\d+$/ and 94 | croak "OutputFilter tie's 1st arg must be numeric"; 95 | ref $ref eq "CODE" or 96 | croak "OutputFilter tie's 3rd arg must be CODE-ref"; 97 | 98 | my $fh; 99 | if (ref $io eq "GLOB" and ref *{$io}{IO} eq "IO::Handle") { 100 | open $fh, ">&", *{$io}{IO}; 101 | } 102 | elsif (ref $io eq "SCALAR") { 103 | open $fh, ">", $io; 104 | } 105 | else { 106 | eval { $fno = fileno $io }; 107 | defined $fno && $fno >= 0 or 108 | croak "OutputFilter tie's 2nd arg must be the output handle\n"; 109 | open $fh, ">&", $fno; 110 | } 111 | $fh or croak "OutputFilter cannot dup the output handle: $!"; 112 | select ((select ($fh), $| = 1)[0]); 113 | 114 | bless { 115 | pfx => " " x $lm, 116 | sb => $ref, 117 | io => $fh, 118 | 119 | line => "", 120 | 121 | closed => 0, 122 | }, $class; 123 | } # TIEHANDLE 124 | 125 | sub BINMODE { 126 | my $self = shift; 127 | $self->{closed} and croak "Cannot set binmode on closed filehandle"; 128 | if (@_) { 129 | my $mode = shift; 130 | binmode $self->{io}, $mode; 131 | } 132 | else { 133 | binmode $self->{io}; 134 | } 135 | } # BINMODE 136 | 137 | sub FILENO { 138 | my $self = shift; 139 | fileno $self->{io}; 140 | } # FILENO 141 | 142 | sub _Filter_ { 143 | my ($nl, $pfx, $sub, $line) = @_; 144 | my $l = $sub->($line); 145 | defined $l ? $pfx . $l . ($nl ? "\n" : "") : ""; 146 | } # _Filter_ 147 | 148 | sub PRINT { 149 | my $self = shift; 150 | my ($pfx, $io, $sub) = @{$self}{qw( pfx io sb )}; 151 | 152 | $self->{closed} and croak "Cannot print to closed filehandle"; 153 | 154 | my $fsep = defined $, ? $, : ""; 155 | my $rsep = defined $\ ? $\ : ""; 156 | my $line = $self->{line} . (join $fsep => @_) . $rsep; 157 | my @line = split m/\n/, $line, -1; 158 | $self->{line} = pop @line; 159 | print { $io } map { _Filter_ (1, $pfx, $sub, $_) } @line; 160 | } # PRINT 161 | 162 | sub PRINTF { 163 | my $self = shift; 164 | my ($pfx, $io, $sub) = @{$self}{qw( pfx io sb )}; 165 | 166 | # Do not delegate this to PRINT, so we can prevent sprintf side effects 167 | $self->{closed} and croak "Cannot print to closed filehandle"; 168 | 169 | my $fmt = shift; 170 | $self->PRINT (sprintf $fmt, @_); 171 | } # PRINTF 172 | 173 | sub TELL { 174 | my $self = shift; 175 | $self->{closed} and croak "Cannot tell from a closed filehandle"; 176 | tell $self->{io}; 177 | } # TELL 178 | 179 | sub EOF { 180 | my $self = shift; 181 | $self->{closed}; 182 | } # EOF 183 | 184 | sub CLOSE { 185 | my $self = shift; 186 | my ($pfx, $io, $sub, $line) = @{$self}{qw( pfx io sb line )}; 187 | defined $line && $line ne "" and 188 | print { $io } _Filter_ (0, $pfx, $sub, $line); 189 | $self->{closed} or close $io; 190 | $self->{line} = ""; 191 | $self->{closed} = 1; 192 | } # CLOSE 193 | 194 | sub UNTIE { 195 | my $self = shift; 196 | $self->{closed} or $self->CLOSE; 197 | $self; 198 | } # UNTIE 199 | 200 | sub DESTROY { 201 | my $self = shift; 202 | $self->{closed} or $self->CLOSE; 203 | %$self = (); 204 | undef $self; 205 | } # DESTROY 206 | 207 | ### ########################################################################### 208 | 209 | sub _outputOnly { 210 | my $name = shift; 211 | sub { croak "No support for $name method: File is output only" }; 212 | } # _outputOnly 213 | 214 | *read = _outputOnly ("read"); 215 | *READ = _outputOnly ("READ"); 216 | *readline = _outputOnly ("readline"); 217 | *READLINE = _outputOnly ("READLINE"); 218 | *getc = _outputOnly ("getc"); 219 | *GETC = _outputOnly ("GETC"); 220 | 221 | sub _NYI { 222 | my $name = shift; 223 | sub { croak "Support for $name method NYI" }; 224 | } # _NYI 225 | 226 | *open = _NYI ("open"); 227 | *OPEN = _NYI ("OPEN"); 228 | *seek = _NYI ("seek"); 229 | *SEEK = _NYI ("SEEK"); 230 | *write = _NYI ("write"); 231 | *WRITE = _NYI ("WRITE"); 232 | 233 | =begin comment 234 | 235 | We do not want to document these: 236 | 237 | =over 4 238 | 239 | =item getc 240 | 241 | =item open 242 | 243 | =item read 244 | 245 | =item readline 246 | 247 | =item seek 248 | 249 | =item write 250 | 251 | =back 252 | 253 | =end comment 254 | 255 | =cut 256 | 257 | 1; 258 | -------------------------------------------------------------------------------- /sandbox/used-by.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use 5.016002; 4 | use warnings; 5 | 6 | our $VERSION = "1.03 - 20180301"; 7 | 8 | sub usage { 9 | my $err = shift and select STDERR; 10 | say "usage: $0 [--list]"; 11 | exit $err; 12 | } # usage 13 | 14 | use blib; 15 | use Cwd; 16 | use LWP; 17 | use LWP::UserAgent; 18 | use HTML::TreeBuilder; 19 | use CPAN; 20 | use Capture::Tiny qw( :all ); 21 | use Term::ANSIColor qw(:constants :constants256); 22 | use Test::More; 23 | 24 | use Getopt::Long qw(:config bundling passthrough); 25 | GetOptions ( 26 | "help|?" => sub { usage (0); }, 27 | "V|version" => sub { say $0 =~ s{.*/}{}r, " [$VERSION]"; exit 0; }, 28 | "a|all!" => \my $opt_a, # Also build for known FAIL (they might have fixed it) 29 | "l|list!" => \my $opt_l, 30 | ) or usage (1); 31 | 32 | my $tm = shift // do { 33 | (my $d = getcwd) =~ s{.*CPAN/([^/]+)(?:/.*)?}{$1}; 34 | $d; 35 | } or die "No module to check\n"; 36 | 37 | diag ("Testing used-by for $tm\n"); 38 | my %tm = map { $_ => 1 } qw( ); 39 | 40 | $| = 1; 41 | $ENV{AUTOMATED_TESTING} = 1; 42 | $ENV{PERL_USE_UNSAFE_INC} = 1; # My modules are not responsible 43 | # Skip all dists that 44 | # - are FAIL not due to the mudule being tested (e.g. POD or signature mismatch) 45 | # - that require interaction (not dealt with in distroprefs or %ENV) 46 | # - are not proper dists (cannot use CPAN's ->test) 47 | # - require external connections or special devices 48 | my %skip = $opt_a ? () : map { $_ => 1 } @{{ 49 | "Data-Peek" => [ 50 | "GSM-Gnokii", # External device 51 | ], 52 | "DBD-CSV" => [ 53 | "ASNMTAP", 54 | "Gtk2-Ex-DBITableFilter", # Unmet prerequisites 55 | ], 56 | "Text-CSV_XS" => [ 57 | "ACME-QuoteDB", # ::CSV Possible precedence issues 58 | "App-Framework", # Questions 59 | "ASNMTAP", # Questions 60 | "Business-Shipping-DataTools", # Questions and unmet prereqs 61 | "Catalyst-TraitFor-Model-DBIC-Schema-QueryLog-AdoptPlack", # maint/Maker.pm 62 | "CGI-Application-Framework", # Unmet prerequisites 63 | "chart", # Questions (in Apache-Wyrd) 64 | "CohortExplorer", # Unmet prerequisites 65 | "Connector", # No Makefile.PL (in Annelidous) 66 | "DBIx-Class-DigestColumns", # unmet prereqs 67 | "DBIx-Class-FilterColumn-ByType", # ::CSV - unmet prereqs 68 | "DBIx-Class-FormTools", # ::CSV POD 69 | "DBIx-Class-FromSledge", # ::CSV Spelling 70 | "DBIx-Class-Graph", # won't build at all 71 | "DBIx-Class-InflateColumn-Serializer-CompressJSON", # ::CSV POD 72 | "DBIx-Class-Loader", # ::CSV Deprecated 73 | "DBIx-Class-QueryProfiler", # ::CSV - Kwalitee test (2011) 74 | "DBIx-Class-RDBOHelpers", # ::CSV - Unmet prereqs 75 | "DBIx-Class-Schema-Slave", # ::CSV - Tests br0ken 76 | "DBIx-Class-Snowflake", # ::CSV - Bad tests. SQLite fail 77 | "DBIx-Class-StorageReadOnly", # ::CSV - POD coverage 78 | "DBIx-NoSQL", # ::CSV - Syntax 79 | "DBIx-Patcher", # ::CSV - Own tests fail 80 | "dbMan", # Questions 81 | "Finance-Bank-DE-NetBank", # Module signatures 82 | "FormValidator-Nested", # ::CSV - Questions 83 | "FreeRADIUS-Database", # ::CSV - Questions 84 | "Fsdb", # ::CSV - 85 | "Geo-USCensus-Geocoding", # '302 Found' 86 | "Gtk2-Ex-DBITableFilter", # Unmet prerequisites 87 | "Gtk2-Ex-Threads-DBI", # Distribution is incomplete 88 | "hwd", # Own tests fail 89 | "Iterator-BreakOn", # ::CSV - Syntax, POD, badness 90 | "Mail-Karmasphere-Client", # ::CSV - No karmaclient 91 | "Module-CPANTS-ProcessCPAN", # ::CSV - Questions 92 | "Module-CPANTS-Site", # ::CSV - Unmet prerequisites 93 | "Net-IPFromZip", # Missing zip file(s) 94 | "Parse-CSV-Colnames", # ::CSV - Fails because of Parse::CSV 95 | "Plack-Middleware-DBIC-QueryLog", # maint/Maker.pm 96 | "Plack-Middleware-Debug-DBIC-QueryLog", # maint/Maker.pm 97 | "RDF-RDB2RDF", # ::CSV - Bad tests 98 | "RT-Extension-Assets-Import-CSV", # Questions 99 | "RT-View-ConciseSpreadsheet", # Questions 100 | "Serge", # Questions in Build.PL ? 101 | "Test-DBIC", # ::CSV - Insecure -T in C3 102 | # "Text-CSV-Encoded", # ::CSV - Encoding, patch filed at RT 103 | "Text-CSV_PP-Simple", # ::CSV - Syntax errors, bad archive 104 | # "Text-CSV-Track", # Encoding, patch filed at RT 105 | "Text-ECSV", # POD, spelling 106 | "Text-MeCab", # Questions 107 | "Text-TEI-Collate", # Unmet prerequisites 108 | "Text-Tradition", # Unmet prerequisites 109 | "Text-xSV-Slurp", # 5.26 incompat, unmaintained 110 | "Tripletail", # Makefile.PL broken 111 | "VANAMBURG-SEMPROG-SimpleGraph", # Own tests fail 112 | "WebService-FuncNet", # ::CSV - WSDL 404, POD 113 | "Webservice-InterMine", # Unmet prerequisites 114 | "WWW-Analytics-MultiTouch", # Unmet prerequisites 115 | "XAS", # ::CSV - No STOMP MQ 116 | "XAS-Model", # ::CSV - No STOMP MQ 117 | "XAS-Spooler", # ::CSV - No STOMP MQ 118 | "xDash", # Questions 119 | # "xls2csv", 120 | "Xymon-DB-Schema", # ::CSV - Bad prereqs 121 | "Xymon-Server-ExcelOutages", # ::CSV - Questions 122 | "YamlTime", # Unmet prerequisites 123 | ], 124 | }->{$tm} // []}; 125 | my %add = ( 126 | "Text-CSV_XS" => [ # Using Text::CSV, thus 127 | "Text-CSV-Auto", # optionally _XS 128 | "Text-CSV-R", 129 | "Text-CSV-Slurp", 130 | ], 131 | ); 132 | 133 | my $ua = LWP::UserAgent->new (agent => "Opera/12.15"); 134 | 135 | sub get_from_cpantesters { 136 | my $m = shift // $tm; 137 | warn "Get from cpantesters ...\n"; 138 | my @h; 139 | foreach my $url ( 140 | "http://deps.cpantesters.org/depended-on-by.pl?dist=$m", 141 | "http://deps.cpantesters.org/depended-on-by.pl?module=$m", 142 | ) { 143 | my $rsp = $ua->request (HTTP::Request->new (GET => $url)); 144 | unless ($rsp->is_success) { 145 | warn "deps failed: ", $rsp->status_line, "\n"; 146 | next; 147 | } 148 | my $tree = HTML::TreeBuilder->new; 149 | $tree->parse_content ($rsp->content); 150 | foreach my $a ($tree->look_down (_tag => "a", href => qr{query=})) { 151 | (my $h = $a->attr ("href")) =~ s{.*=}{}; 152 | push @h, $h; 153 | } 154 | } 155 | return @h; 156 | } # get_from_cpantesters 157 | 158 | sub get_from_cpants { 159 | my $m = shift // $tm; 160 | warn "Get from cpants ...\n"; 161 | my $url = "http://cpants.cpanauthors.org/dist/$m/used_by"; 162 | my $rsp = $ua->request (HTTP::Request->new (GET => $url)); 163 | unless ($rsp->is_success) { 164 | warn "cpants failed: ", $rsp->status_line, "\n"; 165 | return; 166 | } 167 | my $tree = HTML::TreeBuilder->new; 168 | $tree->parse_content ($rsp->content); 169 | my @h; 170 | foreach my $a ($tree->look_down (_tag => "a", href => qr{/dist/})) { 171 | (my $h = $a->attr ("href")) =~ s{.*dist/}{}; 172 | $h =~ m{^$m\b} and next; 173 | push @h, $h; 174 | } 175 | @h or diag ("$url might be rebuilding"); 176 | return @h; 177 | } # get_from_cpants 178 | 179 | sub get_from_meta { 180 | my $m = shift // $tm; 181 | warn "Get from meta ...\n"; 182 | my $url = "https://metacpan.org/requires/distribution/$m"; 183 | my $rsp = $ua->request (HTTP::Request->new (GET => $url)); 184 | unless ($rsp->is_success) { 185 | warn "meta failed: ", $rsp->status_line, "\n"; 186 | return; 187 | } 188 | my $tree = HTML::TreeBuilder->new; 189 | $tree->parse_content ($rsp->content); 190 | my @h; 191 | foreach my $a ($tree->look_down (_tag => "a", class => "ellipsis", 192 | href => qr{/release/})) { 193 | (my $h = $a->attr ("href")) =~ s{.*release/}{}; 194 | $h =~ m{^$m\b} and next; 195 | push @h, $h; 196 | } 197 | return @h; 198 | } # get_from_meta 199 | 200 | sub get_from_sandbox { 201 | open my $fh, "<", "sandbox/used-by.txt" or return; 202 | map { chomp; $_ } <$fh>; 203 | } # get_from_sandbox 204 | 205 | my @h = ( get_from_cpants (), 206 | get_from_cpantesters (), 207 | get_from_meta (), 208 | get_from_sandbox (), 209 | @{$add{$tm} || []}); 210 | 211 | $tm eq "Text-CSV_XS" and push @h, 212 | get_from_cpants ("Text-CSV"), 213 | get_from_cpantesters ("Text-CSV"), 214 | get_from_meta ("Text-CSV"); 215 | 216 | foreach my $h (@h) { 217 | exists $skip{$h} || $h =~ m{^( $tm (?: $ | / ) 218 | | Task- 219 | | Bundle- 220 | | Win32- 221 | )\b}x and next; 222 | (my $m = $h) =~ s/-/::/g; 223 | $tm{$m} = 1; 224 | } 225 | 226 | warn "fetched ", scalar keys %tm, " keys\n"; 227 | 228 | unless (keys %tm) { 229 | ok (1, "No dependents found"); 230 | done_testing; 231 | exit 0; 232 | } 233 | 234 | if ($opt_l) { 235 | ok (1, $_) for sort keys %tm; 236 | done_testing; 237 | exit 0; 238 | } 239 | 240 | my %rslt; 241 | foreach my $m (sort keys %tm) { 242 | my $mod = CPAN::Shell->expand ("Module", "/$m/") or next; 243 | # diag $m; 244 | $rslt{$m} = [ [], capture { $mod->test } ]; 245 | $rslt{$m}[0] = [ $?, $!, $@ ]; 246 | # say $? ? RED."FAIL".RESET : GREEN."PASS".RESET; 247 | is ($?, 0, $m); 248 | } 249 | 250 | done_testing; 251 | -------------------------------------------------------------------------------- /sandbox/genMETA.pm: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | package genMETA; 4 | 5 | our $VERSION = "1.18-20250113"; 6 | 7 | use 5.014001; 8 | use warnings; 9 | use Carp; 10 | 11 | use CPAN::Meta::Converter; 12 | use CPAN::Meta::Validator; 13 | use Data::Peek; 14 | use Date::Calc qw( Delta_Days ); 15 | use Encode qw( encode decode ); 16 | use File::Find; 17 | use JSON::PP; 18 | use List::Util qw( first ); 19 | use Parse::CPAN::Meta; 20 | use Software::Security::Policy::Individual; 21 | use Term::ANSIColor qw(:constants); 22 | use Test::CPAN::Meta::YAML::Version; 23 | use Test::More (); 24 | use Text::Diff; 25 | use YAML::Syck; 26 | 27 | sub new { 28 | my $package = shift; 29 | return bless { @_ }, $package; 30 | } # new 31 | 32 | sub extract_version { 33 | my $fh = shift; 34 | my @vsn; 35 | while (<$fh>) { 36 | m/\$VERSION\b/ and push @vsn => $_; 37 | m{^(?:our\s+)? # declaration 38 | \$VERSION \s*=\s* # variable 39 | ["']? ([0-9._]+) # version 40 | (?:\s* - \s* [0-9]{4}-?[0-9]{2}-?[0-9]{2} \s*)? # date "0.01 - 20230412" 41 | ['"]? 42 | \s*;\s* 43 | (?:\x23 \s* [0-9]{4}-?[0-9]{2}-?[0-9]{2} \s*)? # date "0.01"; # 20230502 44 | $}x or next; 45 | return $1; 46 | } 47 | # No match on first scan, try without date 48 | for (@vsn) { 49 | m{^(?:our\s+)? # declaration 50 | \$VERSION \s*=\s* # variable 51 | ([""'']) ([0-9._]+) \1 # version 52 | \s*; 53 | }x or next; 54 | return $2; 55 | } 56 | } # extract_version 57 | 58 | sub version_from { 59 | my ($self, $src) = @_; 60 | 61 | $self->{mfpr} = {}; 62 | if (open my $mh, "<", "Makefile.PL") { 63 | my $mf = do { local $/; <$mh> }; 64 | 65 | if ($mf =~ m{\b NAME \s*=>\s* ["'] (\S+) ['"]}x) { 66 | $self->{name} = $1; 67 | $self->{name} =~ m/-/ and 68 | warn RED, "NAME in Makefile.PL contains a -", RESET, "\n"; 69 | $self->{name} =~ s/::/-/g; 70 | } 71 | if ($mf =~ m{\b DISTNAME \s*=>\s* ["'] (\S+) ['"]}x) { 72 | $self->{name} = $1; 73 | } 74 | 75 | if ($mf =~ m{\b VERSION_FROM \s*=>\s* ["'] (\S+) ['"]}x) { 76 | my $from = $1; 77 | -f $from or 78 | croak RED, "Makefile wants version from nonexisten $from", RESET, "\n"; 79 | $self->{from} //= $from; 80 | $from eq $self->{from} or 81 | croak RED, "VERSION_FROM mismatch Makefile.PL ($from) / YAML ($self->{from})", RESET, "\n"; 82 | } 83 | 84 | if ($mf =~ m[\b PREREQ_PM \s*=>\s* \{ ( [^}]+ ) \}]x) { 85 | my @pr = split m/\n/ => $1; 86 | $self->{mfpr} = { map { (m{ \b ["']? (\S+?) ['"]? \s*=>\s* ["']? ([-0-9._]+) ['"]? }x) } grep !m/^\s*#/ => @pr }; 87 | } 88 | 89 | $mf =~ m{--format=ustar} or 90 | warn RED, "TARFLAGS macro is missing", RESET, "\n"; 91 | } 92 | 93 | $src //= $self->{from} or croak "No file to extract version from"; 94 | 95 | open my $pm, "<", $src or croak "Cannot read $src"; 96 | my $version = extract_version ($pm) or croak "Cannot extract VERSION from $src\n"; 97 | close $pm; 98 | $self->{version} = $version; 99 | return $version 100 | } # version_from 101 | 102 | sub from_data { 103 | my ($self, @data) = @_; 104 | $self->{version} or $self->version_from (); 105 | s/VERSION/$self->{version}/g for @data; 106 | my ($dsct, $dmod); 107 | for (@data) { 108 | s/[ \t]+$//; 109 | m/^\s*(\w+):$/ and $dsct = $1; 110 | m/^\s*(\w(?:[\w:]+\w)?):\s+\d/ and $dmod = $1; 111 | s/\s+#\s*ignore\b\s*[:=]?\s*(\S+)$//i or next; 112 | $self->{cve_ignore}{$dsct}{$dmod} = $1; 113 | } 114 | $self->{yml} = \@data; 115 | $self->check_yaml (); 116 | $self->check_provides (); 117 | #DDumper $self->{cve_ignore}; 118 | return @data; 119 | } # from_data 120 | 121 | sub check_encoding { 122 | my $self = shift; 123 | my @tf = grep m{^(?: change | readme | .*\.pod )}ix => glob "*"; 124 | (my $tf = join ", " => @tf) =~ s/.*\K, / and /; 125 | 126 | print "Check if $tf are still valid UTF8 ...\n"; 127 | foreach my $tf (@tf) { 128 | open my $fh, "<", $tf or croak "$tf: $!\n"; 129 | my @c = <$fh>; 130 | my $c = join "" => @c; 131 | my @e; 132 | my $s = decode ("utf-8", $c, sub { push @e, shift; }); 133 | if (@e) { 134 | my @l; 135 | my $n = 0; 136 | for (@c) { 137 | $n++; 138 | eval { decode ("utf-8", $_, 1) }; 139 | $@ or next; 140 | $@ =~ s{ at /\S+ line \d+.*}{}; 141 | print BLUE, "$tf:$n\t$_\t$@", RESET; 142 | } 143 | croak "$tf is not valid UTF-8\n"; 144 | } 145 | my $u = encode ("utf-8", $s); 146 | $c eq $u and next; 147 | 148 | my $n; 149 | $n = 1; $c =~ s/^/$n++ . "\t"/gem; 150 | $n = 1; $u =~ s/^/$n++ . "\t"/gem; 151 | croak "$tf: recode makes content differ\n". diff \$c, \$u; 152 | } 153 | } # check_encoding 154 | 155 | sub check_required { 156 | my $self = shift; 157 | 158 | my $yml = $self->{h} or croak "No YAML to check"; 159 | 160 | warn "Check required and recommended module versions ...\n"; 161 | BEGIN { $V::NO_EXIT = $V::NO_EXIT = 1 } require V; 162 | my %req = map { %{$yml->{$_}} } grep m/requires/ => keys %{$yml}; 163 | my %rec = map { %{$yml->{$_}} } grep m/recommends/ => keys %{$yml}; 164 | my %sug = map { %{$yml->{$_}} } grep m/suggests/ => keys %{$yml}; 165 | if (my $of = $yml->{optional_features}) { 166 | foreach my $f (values %{$of}) { 167 | my %q = map { %{$f->{$_}} } grep m/requires/ => keys %{$f}; 168 | my %c = map { %{$f->{$_}} } grep m/recommends/ => keys %{$f}; 169 | my %s = map { %{$f->{$_}} } grep m/suggests/ => keys %{$f}; 170 | @req{keys %q} = values %q; 171 | @rec{keys %c} = values %c; 172 | @sug{keys %s} = values %s; 173 | } 174 | } 175 | if (my $of = $yml->{prereqs}) { 176 | foreach my $f (values %{$of}) { 177 | my %q = map { %{$f->{$_}} } grep m/requires/ => keys %{$f}; 178 | my %c = map { %{$f->{$_}} } grep m/recommends/ => keys %{$f}; 179 | my %s = map { %{$f->{$_}} } grep m/suggests/ => keys %{$f}; 180 | @req{keys %q} = values %q; 181 | @rec{keys %c} = values %c; 182 | @sug{keys %s} = values %s; 183 | } 184 | } 185 | my %vsn = ( %req, %rec, %sug ); 186 | delete @vsn{qw( perl version )}; 187 | for (sort keys %vsn) { 188 | if (my $mfv = delete $self->{mfpr}{$_}) { 189 | $req{$_} eq $mfv or 190 | croak RED, "PREREQ mismatch for $_ Makefile.PL ($mfv) / YAML ($req{$_})", RESET, "\n"; 191 | } 192 | $vsn{$_} eq "0" and next; 193 | my $v = V::get_version ($_); 194 | $v eq $vsn{$_} and next; 195 | printf STDERR "%s%-35s %-6s => %s%s%s\n", BLUE, $_, $vsn{$_}, GREEN, $v, RESET; 196 | } 197 | if (my @mfpr = grep { $_ ne "version" } sort keys %{$self->{mfpr}}) { 198 | croak RED, "Makefile.PL requires @mfpr, YAML does not", RESET, "\n"; 199 | } 200 | 201 | find (sub { 202 | $File::Find::dir =~ m{^blib\b} and return; 203 | $File::Find::name =~ m{(?:^|/)Bundle/.*\.pm} or return; 204 | if (open my $bh, "<", $_) { 205 | warn "Check bundle module versions $File::Find::name ...\n"; 206 | while (<$bh>) { 207 | my ($m, $dv) = m/^([A-Za-z_:]+)\s+([0-9.]+)\s*$/ or next; 208 | my $v = $m eq $self->{name} ? $self->{version} : V::get_version ($m); 209 | $v eq $dv and next; 210 | printf STDERR "%s%-35s %-6s => %s%s%s\n", BLUE, $m, $dv, GREEN, $v, RESET; 211 | } 212 | } 213 | }, glob "*"); 214 | } # check_required 215 | 216 | sub check_yaml { 217 | my $self = shift; 218 | 219 | my @yml = @{$self->{yml}} or croak "No YAML to check"; 220 | 221 | warn "Checking generated YAML ...\n" unless $self->{quiet}; 222 | my $h; 223 | my $yml = join "", @yml; 224 | eval { $h = Load ($yml) }; 225 | $@ and croak "$@\n"; 226 | $self->{name} //= $h->{name}; 227 | $self->{name} eq $h->{name} or 228 | croak RED, "NAME mismatch Makefile.PL / YAML", RESET, "\n"; 229 | $self->{name} =~ s/-/::/g; 230 | warn "Checking for $self->{name}-$self->{version}\n" unless $self->{quiet}; 231 | 232 | $self->{verbose} and print Dump $h; 233 | 234 | my $t = Test::CPAN::Meta::YAML::Version->new (data => $h); 235 | $t->parse () and 236 | croak join "\n", "Test::CPAN::Meta::YAML reported failure:", $t->errors, ""; 237 | 238 | eval { Parse::CPAN::Meta::Load ($yml) }; 239 | $@ and croak "$@\n"; 240 | 241 | $self->{h} = $h; 242 | $self->{yaml} = $yml; 243 | } # check_yaml 244 | 245 | sub check_minimum { 246 | my $self = shift; 247 | my $reqv = $self->{h}{requires}{perl} || $self->{h}{prereqs}{runtime}{requires}{perl}; 248 | my $locs; 249 | 250 | for (@_) { 251 | if (ref $_ eq "ARRAY") { 252 | $locs = { paths => $_ }; 253 | } 254 | elsif (ref $_ eq "HASH") { 255 | $locs = $_; 256 | } 257 | else { 258 | $reqv = $_; 259 | } 260 | } 261 | my $paths = (join ", " => @{($locs // {})->{paths} // []}) || "default paths"; 262 | 263 | $reqv or croak "No minimal required version for perl"; 264 | my $tmv = 0; 265 | $reqv > 5.009 and eval "use Test::MinimumVersion::Fast; \$tmv = 1"; 266 | $tmv or eval "use Test::MinimumVersion;"; 267 | print "Checking if $reqv is still OK as minimal version for $paths\n"; 268 | # All other minimum version checks done in xt 269 | Test::More::subtest "Minimum perl version $reqv" => sub { 270 | all_minimum_version_ok ($reqv, $locs); 271 | } or warn RED, "\n### Use 'perlver --blame' on the failing file(s)\n\n", RESET; 272 | } # check_minimum 273 | 274 | sub check_provides { 275 | my $self = shift; 276 | my $prov = $self->{h}{provides}; 277 | 278 | print "Check distribution module versions ...\n"; 279 | 280 | $prov or croak RED, "META does not contain a provides section", RESET, "\n"; 281 | 282 | ref $prov eq "HASH" or 283 | croak RED, "The provides section in META is not a HASH", RESET, "\n"; 284 | 285 | my $fail = 0; 286 | foreach my $m (sort keys %{$prov}) { 287 | my ($file, $pvsn) = @{$prov->{$m}}{qw( file version )}; 288 | unless ($file) { 289 | $fail++; 290 | say RED, " provided $m does not refer to a file", RESET; 291 | next; 292 | } 293 | unless ($pvsn) { 294 | $fail++; 295 | say RED, " provided $m does not declare a version", RESET; 296 | next; 297 | } 298 | 299 | printf " Expect %5s for %-32s ", $pvsn, $m; 300 | open my $fh, "<", $file; 301 | unless ($fh) { 302 | $fail++; 303 | say RED, "$file: $!\n", RESET; 304 | next; 305 | } 306 | 307 | my $version = extract_version ($fh); 308 | close $fh; 309 | unless ($version) { 310 | $fail++; 311 | say RED, "$file does not contain a VERSION", RESET; 312 | next; 313 | } 314 | 315 | if ($version ne $pvsn) { 316 | $fail++; 317 | say RED, "mismatch: $version", RESET; 318 | next; 319 | } 320 | say "ok"; 321 | } 322 | 323 | $fail and exit 1; 324 | } # check_provides 325 | 326 | sub check_changelog { 327 | # Check if the first date has been updated ... 328 | my @td = grep m/^Change(?:s|Log)$/i => glob "[Cc]*"; 329 | unless (@td) { 330 | warn "No ChangeLog to check\n"; 331 | return; 332 | } 333 | my %mnt = qw( jan 1 feb 2 mar 3 apr 4 may 5 jun 6 jul 7 aug 8 sep 9 oct 10 nov 11 dec 12 ); 334 | open my $fh, "<", $td[0] or croak "$td[0]: $!\n"; 335 | while (<$fh>) { 336 | s/\b([0-9]{4}) (?:[- ]) 337 | ([0-9]{1,2}) (?:[- ]) 338 | ([0-9]{1,2})\b/$3-$2-$1/x; # 2015-01-15 => 15-01-2015 339 | m/\b([0-9]{1,2}) (?:[- ]) 340 | ([0-9]{1,2}|[ADFJMNOSadfjmnos][acekopu][abcgilnprtvy]) (?:[- ]) 341 | ([0-9]{4})\b/x or next; 342 | my ($d, $m, $y) = ($1 + 0, ($mnt{lc $2} || $2) + 0, $3 + 0); 343 | printf STDERR "Most recent ChangeLog entry is dated %02d-%02d-%04d\n", $d, $m, $y; 344 | unless ($ENV{SKIP_CHANGELOG_DATE}) { 345 | my @t = localtime; 346 | my $D = Delta_Days ($y, $m , $d, $t[5] + 1900, $t[4] + 1, $t[3]); 347 | $D < 0 and croak RED, "Last entry in $td[0] is in the future!", RESET, "\n"; 348 | $D > 2 and croak RED, "Last entry in $td[0] is not up to date ($D days ago)", RESET, "\n"; 349 | $D > 0 and warn YELLOW, "Last entry in $td[0] is not today", RESET, "\n"; 350 | } 351 | last; 352 | } 353 | close $fh; 354 | } # check_changelog 355 | 356 | sub done_testing { 357 | check_changelog (); 358 | Test::More::done_testing (); 359 | } # done_testing 360 | 361 | sub quiet { 362 | my $self = shift; 363 | @_ and $self->{quiet} = defined $_[0]; 364 | $self->{quiet}; 365 | } # quiet 366 | 367 | sub print_json { 368 | my $self = shift; 369 | my $jsn = $self->{jsn} || $self->add_json (); 370 | print JSON::PP->new->utf8 (1)->pretty (1)->encode ($jsn); 371 | } # print_json 372 | 373 | sub print_yaml { 374 | my $self = shift; 375 | print @{$self->{yml}}; 376 | } # print_yaml 377 | 378 | sub write_yaml { 379 | my ($self, $out) = @_; 380 | $out ||= "META.yml"; 381 | $out =~ s/\.jso?n$/.yml/; 382 | open my $fh, ">", $out or croak "$out: $!\n"; 383 | print $fh @{$self->{yml}}; 384 | close $fh; 385 | $self->fix_meta ($out); 386 | } # print_yaml 387 | 388 | sub add_json { 389 | my $self = shift; 390 | # Convert to meta-spec version 2 391 | # licenses are lists now 392 | my $jsn = $self->{h}; 393 | $jsn->{"meta-spec"} = { 394 | version => "2", 395 | url => "https://metacpan.org/module/CPAN::Meta::Spec?#meta-spec", 396 | }; 397 | exists $jsn->{resources}{license} and 398 | $jsn->{resources}{license} = [ $jsn->{resources}{license} ]; 399 | delete $jsn->{distribution_type}; 400 | if (exists $jsn->{license}) { 401 | if (ref $jsn->{license} eq "ARRAY") { 402 | $jsn->{license}[0] =~ s/^perl$/perl_5/i; 403 | } 404 | else { 405 | $jsn->{license} =~ s/^perl$/perl_5/i; 406 | $jsn->{license} = [ $jsn->{license} ]; 407 | } 408 | } 409 | if (exists $jsn->{resources}{bugtracker}) { 410 | my $url = $jsn->{resources}{bugtracker}; 411 | $jsn->{resources}{bugtracker} = { 412 | web => $url, 413 | }; 414 | } 415 | if (exists $jsn->{resources}{repository}) { 416 | my $url = $jsn->{resources}{repository}; 417 | my $web = $url; 418 | $url =~ s{repo.or.cz/w/}{repo.or.cz/r/}; 419 | $web =~ s{repo.or.cz/r/}{repo.or.cz/w/}; 420 | $jsn->{resources}{repository} = { 421 | type => "git", 422 | web => $web, 423 | url => $url, 424 | }; 425 | } 426 | foreach my $sct ("", "configure_", "build_", "test_") { 427 | (my $x = $sct || "runtime") =~ s/_$//; 428 | for (qw( requires recommends suggests )) { 429 | exists $jsn->{"$sct$_"} and 430 | $jsn->{prereqs}{$x}{$_} = delete $jsn->{"$sct$_"}; 431 | } 432 | } 433 | 434 | # optional features do not yet know about requires and/or recommends diirectly 435 | if (my $of = $jsn->{optional_features}) { 436 | foreach my $f (keys %$of) { 437 | if (my $r = delete $of->{$f}{requires}) { 438 | #$jsn->{prereqs}{runtime}{recommends}{$_} //= $r->{$_} for keys %$r; 439 | $of->{$f}{prereqs}{runtime}{requires} = $r; 440 | } 441 | if (my $r = delete $of->{$f}{recommends}) { 442 | #$jsn->{prereqs}{runtime}{recommends}{$_} //= $r->{$_} for keys %$r; 443 | $of->{$f}{prereqs}{runtime}{recommends} = $r; 444 | } 445 | if (my $r = delete $of->{$f}{suggests}) { 446 | #$jsn->{prereqs}{runtime}{suggests}{$_} //= $r->{$_} for keys %$r; 447 | $of->{$f}{prereqs}{runtime}{suggests} = $r; 448 | } 449 | } 450 | } 451 | 452 | $jsn = CPAN::Meta::Converter->new ($jsn)->convert (version => "2"); 453 | $jsn->{generated_by} = "Author"; 454 | $self->{jsn} = $jsn; 455 | } # add_json 456 | 457 | sub fix_meta { 458 | my ($self, $yf) = @_; 459 | 460 | my $jsn = $self->add_json (); 461 | 462 | my $cmv = CPAN::Meta::Validator->new ($jsn); 463 | $cmv->is_valid or 464 | croak join "\n" => RED, "META Validator found fail:\n", $cmv->errors, RESET, ""; 465 | 466 | unless ($yf) { 467 | my @my = grep { -s } glob ("*/META.yml"), "META.yml" or croak "No META files"; 468 | $yf = $my[0]; 469 | } 470 | my $jf = $yf =~ s/yml$/json/r; 471 | open my $jh, ">", $jf or croak "Cannot update $jf: $!\n"; 472 | print $jh JSON::PP->new->utf8 (1)->pretty (1)->encode ($jsn); 473 | close $jh; 474 | 475 | # Now that 2.0 JSON is corrrect, create a 1.4 YAML back from the modified stuff 476 | my $yml = $jsn; 477 | # 1.4 does not know about test_*, move them to * 478 | if (my $tp = delete $yml->{prereqs}{test}) { 479 | foreach my $phase (keys %{$tp}) { 480 | my $p = $tp->{$phase}; 481 | #DDumper { $phase => $p }; 482 | $yml->{prereqs}{runtime}{$phase}{$_} //= $p->{$_} for keys %{$p}; 483 | } 484 | } 485 | 486 | # Optional features in 1.4 knows requires, but not recommends. 487 | # The Lancaster Consensus moves 2.0 optional recommends promote to 488 | # requires in 1.4 489 | if (my $of = $yml->{optional_features}) { 490 | foreach my $f (keys %$of) { 491 | if (my $r = delete $of->{$f}{prereqs}{runtime}{recommends}) { 492 | $of->{$f}{requires} = $r; 493 | } 494 | if (my $r = delete $of->{$f}{prereqs}{runtime}{suggests}) { 495 | $of->{$f}{suggests} = $r; 496 | } 497 | } 498 | } 499 | # runtime and test_requires are unknown as top-level in 1.4 500 | foreach my $phase (qw( xuntime test_requires )) { 501 | if (my $p = delete $yml->{$phase}) { 502 | foreach my $f (keys %$p) { 503 | $yml->{$f}{$_} ||= $p->{$f}{$_} for keys %{$p->{$f}}; 504 | } 505 | } 506 | } 507 | 508 | #DDumper $yml; 509 | # This does NOT create a correct YAML id the source does not comply! 510 | $yml = CPAN::Meta::Converter->new ($yml)->convert (version => "1.4"); 511 | $yml->{requires}{perl} //= $jsn->{prereqs}{runtime}{requires}{perl} 512 | // $self->{h}{requires}{perl} 513 | // ""; 514 | $yml->{build_requires} && !keys %{$yml->{build_requires}} and 515 | delete $yml->{build_requires}; 516 | #DDumper $yml; 517 | #exit; 518 | 519 | open my $my, ">", $yf or croak "Cannot update $yf: $!\n"; 520 | print $my Dump $yml; # @{$self->{yml}}; 521 | close $my; 522 | 523 | chmod 0644, glob "*/META.*"; 524 | unlink glob "MYMETA*"; 525 | } # fix_meta 526 | 527 | sub _cpfd { 528 | my ($self, $jsn, $sct, $f) = @_; 529 | 530 | open my $sh, ">", \my $b; 531 | my $sep = ""; 532 | for (qw( requires recommends suggests )) { 533 | my $x = "$sct$_"; 534 | my $s = $jsn->{$x} or next; 535 | print $sh $sep; 536 | foreach my $m (sort keys %$s) { 537 | $m eq "perl" and next; 538 | my $v = $s->{$m}; 539 | printf $sh qq{%-10s "%s"}, $_, $m; 540 | my $aw = (24 - length $m); $aw < 0 and $aw = 0; 541 | printf $sh qq{%s => "%s"}, " " x $aw, $v if $v; 542 | print $sh ";"; 543 | if (my $i = $self->{cve_ignore}{$x}{$m}) { 544 | print $sh " # ignore : $i"; 545 | } 546 | say $sh ""; 547 | } 548 | $sep = "\n"; 549 | } 550 | close $sh; 551 | $sct || $f and $b and $b .= "};"; 552 | return $b; 553 | } # _cpfd 554 | 555 | sub gen_cpanfile { 556 | my $self = shift; 557 | 558 | warn "Generating cpanfile ...\n"; 559 | open my $fh, ">", "cpanfile"; 560 | 561 | my $jsn = $self->{h}; 562 | foreach my $sct_ ("", "configure_", "build_", "test_", "runtime_") { 563 | 564 | my $sct = $sct_ =~ s/_$//r; 565 | 566 | my $b = _cpfd ($self, $jsn, $sct_, 0) or next; 567 | 568 | if ($sct) { 569 | say $fh qq/\non "$sct" => sub {/; 570 | say $fh $b =~ s/^(?=\S)/ /gmr; 571 | } 572 | else { 573 | print $fh $b; 574 | } 575 | } 576 | 577 | if (my $of = $jsn->{optional_features}) { 578 | foreach my $f (sort keys %$of) { 579 | my $fs = $of->{$f}; 580 | say $fh qq/\nfeature "$f", "$fs->{description}" => sub {/;#} 581 | say $fh _cpfd ($self, $fs, "", 1) =~ s/^(?=\S)/ /gmr; 582 | } 583 | } 584 | 585 | close $fh; 586 | 587 | warn "Check CVE's ...\n"; 588 | if (system "cpan-cve.pl", "-d", ".") { 589 | warn "### CVE WARNING\n"; 590 | warn "#\n"; 591 | warn "# The current release would have recommended versions\n"; 592 | warn "# with known CVE's that are not (yet) ignored\n"; 593 | sleep (5); 594 | } 595 | } # gen_cpanfile 596 | 597 | sub security_md { 598 | my ($self, $update) = @_; 599 | 600 | my $sfn = "SECURITY.md"; 601 | my $policy = Software::Security::Policy::Individual->new ({ 602 | maintainer => $self->{h}{author}[0], 603 | program => $self->{name}, 604 | timeframe => "10 days", 605 | url => $self->{h}{resources}{repository}, 606 | perl_support_years => 5, 607 | }); 608 | 609 | my $smd = $policy->fulltext; 610 | 611 | unless (-s $sfn) { 612 | open my $fh, ">:encoding(utf-8)", $sfn or die "$sfn: $! \n"; 613 | print $fh $smd; 614 | close $fh; 615 | 616 | if (open $fh, "<", "MANIFEST") { 617 | my @m = <$fh>; 618 | close $fh; 619 | unless (grep m/^$sfn(?:\s|$)/ => @m) { 620 | open $fh, ">>", "MANIFEST" or die "MANIFEST: $!\n"; 621 | say $fh "$sfn\t\tGuide for reporting security issues"; 622 | close $fh; 623 | } 624 | } 625 | say "$sfn added"; 626 | } 627 | 628 | open my $fh, "<:encoding(utf-8)", $sfn or die "$sfn: $!\n"; 629 | my $old = do { local $/; <$fh> }; 630 | close $fh; 631 | 632 | $old eq $smd and return; 633 | 634 | if ($update) { 635 | open my $fh, ">:encoding(utf-8)", $sfn or die "$sfn: $!\n"; 636 | print $fh $smd; 637 | close $fh; 638 | say "$sfn updated"; 639 | } 640 | else { 641 | say "$sfn required updates:"; 642 | say diff \$old, \$smd; 643 | say "to apply, use $0 --check --update"; 644 | } 645 | } # gen_security 646 | 647 | 1; 648 | --------------------------------------------------------------------------------