#!/usr/bin/perl -w
################################################################################
## MARK -- emphasizes part matching a pattern
##
## - It behaves like the filter program.
## - The back and forth 5 lines are displayed in default.
##
## - $Revision: 2.6 $
##
## - Author: 2006-2025, tomyama
## - Intended primarily for personal use, but BSD license permits redistribution.
##
## BSD 2-Clause License:
## Copyright (c) 2006-2025, tomyama
## All rights reserved.
################################################################################

use strict;
use warnings 'all';
use File::Basename;
#use IO::Handle;

exit( &pl_main( @ARGV ) );

##########
## スクリプトのエントリポイント
sub pl_main()
{

    ## 初期化処理
    &init_script();

    ## 引数解析
    &parse_arg( @_ );

    ## デバッグ用 : パラメータ出力
    if( $main::debug ){
        &prt_param();
    }

#    STDIN->autoflush(1);

    my $file_num = scalar( @main::fi_in );
    my $file_name_len_max = 0;
    my $num_char_disp_area = 8;
    if( $main::prt_fname ){
        for( my $file_idx=0; $file_idx<$file_num; $file_idx++ ){
            my $cur_len = length( $main::fi_in[ $file_idx ] );
            $file_name_len_max = ( $cur_len > $file_name_len_max ? $cur_len : $file_name_len_max );
        }
        $num_char_disp_area = ( ( ( int( $file_name_len_max / 8 ) ) + 1 ) * 8 ) - 1;
    }
    for( my $file_idx=0; $file_idx<$file_num; $file_idx++ ){
        my $opn_fname = $main::fi_in[ $file_idx ];

        if( $main::debug ){
            print STDERR ( qq{ ***** [ $opn_fname ] *****\n});
        }

        open( FI_IN, "<$opn_fname" ) ||
            die( qq{$main::appname: error: "$opn_fname": could not open file: $!\n} );
        my $nr = 0;
        while( <FI_IN> ){
            $nr++;
            my $mybuff = $_;
            $mybuff =~ s/\r?\n$//o;

            ## マーキングする
            my $match_flg = 0;
            if( $main::bIsStdoutATty || $main::bForceColor ){
                if( $main::ignorecase ){
                    if( $mybuff =~ s/($main::re)/\033[1m$1\033[0m/igo ){
                        $match_flg = 1;
                    }
                }else{
                    if( $mybuff =~ s/($main::re)/\033[1m$1\033[0m/go ){
                        $match_flg = 1;
                    }
                }
            }else{
                if( $main::ignorecase ){
                    if( $mybuff =~ m/($main::re)/igo ){
                        $match_flg = 1;
                    }
                }else{
                    if( $mybuff =~ m/($main::re)/go ){
                        $match_flg = 1;
                    }
                }
            }

            ## マッチしていなかったら
            if ($main::flag_filter && ! $match_flg) {
                ## 後方行の出力
                $main::post_buffer_counter--;
                if( $main::post_buffer_counter >= 0 ){
                    goto PRINTOUT;
                }

                ## 前方行をバッファに溜めておく
                ## buffer_pre=0 の場合はバッファは必要無し
                if( $main::buffer_pre == 0 ){
                    next;
                ## バッファが満杯であれば整理しておく
                }elsif( scalar( @main::pre_buffer ) >= $main::buffer_pre ){
                    shift( @main::pre_buffer );
                }

                ## バッファに溜める
                push( @main::pre_buffer, $mybuff );
                next;
            ## マッチしていたら
            }elsif( $main::flag_filter ){
                ## 読み易いように、skip...を出力
                if( $main::post_buffer_counter + scalar( @main::pre_buffer ) < 0 ){
                    if( $main::bIsStdoutATty || $main::bForceColor ){
                        print( "        \033[34m*** skip ***\033[0m\n" );
                    }else{
                        print( "        *** skip ***\n" );
                    }
                }

                ## バッファを吐き出す
                my $pre_buffer_size = scalar( @main::pre_buffer );
                my $nr_first = $nr - $pre_buffer_size;
                for( my $pre_buffer_idx=0; $pre_buffer_idx<$pre_buffer_size; $pre_buffer_idx++ ){
                    ## 必要に応じてファイル名を出力
                    if( $main::prt_fname ){
                        printf( "%-${num_char_disp_area}s:", $opn_fname );
                    }
                    ## 必要に応じて行番号を出力
                    if( $main::numbering ){
                        printf( "%7d:", $nr_first + $pre_buffer_idx ) ;
                    }
                    ## 出力する
                    print( "$main::pre_buffer[ $pre_buffer_idx ]\n" );
                }
                undef( @main::pre_buffer );

                ## 後方行出力用のカウンタをセットする
                $main::post_buffer_counter = $main::buffer_post;
            }

            PRINTOUT:
            ## 必要に応じてファイル名を出力
            if( $main::prt_fname ){
                printf( "%-${num_char_disp_area}s:", $opn_fname );
            }
            ## 必要に応じて行番号を出力
            if( $main::numbering ){
                printf( "%7d:", $nr );
            }
            ## 出力する
            print( "$mybuff\n" );
        }
        close( FI_IN );
    }

    return 0;
}

##########
## 初期化処理
## Revision: 1.3
sub init_script()
{
    ### GLOBAL ###
    $main::apppath = dirname( $0 );
    $main::appname = basename( $0 );
    $main::debug = 0;
    $main::numbering = 0;
    $main::prt_fname = 0;
    $main::flag_filter = 0;
    $main::buffer_pre  = 0;
    $main::buffer_post = 0;
    @main::pre_buffer = ();
    $main::post_buffer_counter = 0;
    $main::ignorecase = 0;
    $main::re = undef;
    @main::fi_in = ();
    $main::bIsStdoutATty = -t STDOUT;
    $main::bForceColor = 0;
    ##############
}

##########
## デバッグ用 : パラメータ出力
sub prt_param()
{
    print STDERR ( qq{ ***** PARAMETER *****\n} );
    print STDERR ( qq{\$main::apppath = "$main::apppath"\n} );
    print STDERR ( qq{\$main::appname = "$main::appname"\n} );
    print STDERR ( qq{\$main::debug = $main::debug\n} );
    print STDERR ( qq{\$main::bIsStdoutATty = $main::bIsStdoutATty\n} );
    print STDERR ( qq{\$main::bForceColor = $main::bForceColor\n} );
    print STDERR ( qq{\$main::numbering = $main::numbering\n} );
    print STDERR ( qq{\$main::prt_fname = $main::prt_fname\n} );
    print STDERR ( qq{\$main::flag_filter = $main::flag_filter\n} );
    print STDERR ( qq{\$main::buffer_pre = $main::buffer_pre\n} );
    print STDERR ( qq{\$main::buffer_post = $main::buffer_post\n} );
    print STDERR ( qq{\$main::ignorecase = $main::ignorecase\n} );
    print STDERR ( qq{\$main::re = "$main::re"\n} );
    my $idx_max = scalar( @main::fi_in );
    print STDERR ( qq{\@main::fi_in = $idx_max\n} );
    for( my $idx = 0; $idx < $idx_max; $idx++ ){
        print STDERR ( qq{\$main::fi_in[ $idx ] = "$main::fi_in[ $idx ]"\n} );
    }
}

##########
## 引数解析
sub parse_arg()
{
    my @val = @_;

    my $opt_nofname = 0;

    ## 引数分のループを回す
    while( my $myparam = shift( @val ) ){
        ## アルファベットは1文字ずつ（-d, -h, -w）
        if( $myparam =~ s/^-([dfhHvinc])([dfhHvinc\d,]+)$/-$1/o ){
            my $remainparam = "-$2";
            ## （"(\d+)"の部分はperlの最大マッチに依存した記述。変更時は注意）
            if( $myparam eq '-f' ){
                if( $remainparam =~ s/^-(\d+(?:,\d+)?)([dfhHvinc]*)$/-$2/o ){
                    if( $remainparam ne '-' ){
                        unshift( @val, $remainparam );
                    }
                    unshift( @val, "$1" );
                }else{
                    unshift( @val, $remainparam );
                }
            }else{
                unshift( @val, $remainparam );
            }
        }

        ## デバッグモードOn
        if    ( $myparam eq '-d' || $myparam eq '--debug' ){
                $main::debug = 1;
        }elsif( $myparam eq '--test-force-tty' ){
            $main::bIsStdoutATty = 1;
        }elsif( $myparam eq '-f' ){
                $main::flag_filter = 1;
                $main::buffer_pre  = 5;
                $main::buffer_post = 5;
            if( defined( $val[ 0 ] ) ){
                if( $val[ 0 ] =~ m/^(\d+)(?:,(\d+))?$/o ){
                    ## 捨てる
                    shift( @val );

                    $main::buffer_pre  = $1;
                    $main::buffer_post = $1;
                    if( defined( $2 ) ){
                        $main::buffer_post = $2;
                    }
                }
            }
        }elsif( $myparam eq '-H' || $myparam eq '--with-filename' ){
            $main::prt_fname = 1;
        }elsif( $myparam eq '-h' || $myparam eq '--no-filename' ){
            $opt_nofname = 1;
        }elsif( $myparam eq '--help' ){
            &usage( 0 );
            exit( 0 );
        }elsif( $myparam eq '-v' || $myparam eq '--version' ){
            &PrintVersion();
            exit( 0 );
        }elsif( $myparam eq '-i' || $myparam eq '--ignore-case' ){
            $main::ignorecase = 1;
        }elsif( $myparam eq '-n' || $myparam eq '--line-number' ){
            $main::numbering = 1;
        }elsif( $myparam eq '-c' || $myparam eq '--force-color' ){
            $main::bForceColor = 1;
        }else{
            if( ! defined( $main::re ) ){
                $main::re = $myparam;
            }else{
                if( "$myparam" eq '-' ){
                    my $fi_in_max = scalar( @main::fi_in );
                    for( my $idx=0; $idx<$fi_in_max; $idx++ ){
                        if( $main::fi_in[ $idx ] eq '-' ){
                            &myerr( qq{"STDIN(-)" cannot be specified more than once.\n} );
                            exit( 1 );
                        }
                    }
                }elsif( ( ! -f "$myparam" ) &&
                    ( "$myparam" ne 'A_FICTITIOUS_UNREADABLE_FILE_FOR_TESTING_PURPOSES' ) ){
                    if( "$myparam" ne 'A_FICTITIOUS_FILE_FOR_TESTING_PURPOSES' ){
                        &myerr( qq{"$myparam": file not found.\n} );
                        &myerr( qq{You have specified "$main::re" for <PATTERN>.\n} );
                        &myerr( qq{So I think of "$myparam" as a <FILE> designation.\n} );
                        &usage( 1 );
                        exit( 1 );
                    }
                }elsif( ! -r "$myparam" ){
                    &myerr( qq{"$myparam": permission denied.\n} );
                    &usage( 1 );
                    exit( 1 );
                }
                push( @main::fi_in, $myparam );
            }
        }
        if( $main::debug ){
            printf STDERR ( qq{arg="$myparam", \@val=%d\n}, scalar( @val ) );
        }
    }

    if( ! defined( $main::re ) ){
        &myerr( qq{Please specify the Regular Expressions.\n} );
        &usage( 1 );
        exit( 1 );
    }

    my $fi_in_nums = scalar( @main::fi_in );
    if( $fi_in_nums == 0 ){
        push( @main::fi_in, '-' );
    }elsif( $fi_in_nums > 1 ){
        if( $opt_nofname == 0 ){
            $main::prt_fname = 1;
        }
    }
}

#sub mywarn()
#{
#    warn( qq{$main::appname: warn: }, @_ );
#}

sub myerr()
{
    warn( qq{$main::appname: error: }, @_ );
}

## Revision: 1.2
sub PrintVersion()
{
    my $ver = &GetVersion();
    my $v = qq{Version: $ver\n} .
            qq{   Perl: $^V\n};
    print( $v );
}
sub GetVersion()
{
    my $rev = &GetRevision();

    my $major = 1;
    my( $minor, $revision ) = split( /\./, $rev );
    my $version = sprintf( '%d.%02d.%03d', $major, $minor, $revision );

    return $version;
}
sub GetRevision()
{
    my $rev = q{$Revision: 2.6 $};
    $rev =~ s!^\$[R]evision: (\d+\.\d+) \$$!$1!o;
    return $rev;
}

##########
## 書式表示
## Revision: 1.2
sub usage( $ )
{
    my $msg = "Usage: " .
        qq{$main::appname [<OPTIONS...>] <PATTERN> [<FILE...>]\n} .
        qq{\n} .
        qq{<PATTERN>: The PATTERN can be described by the Regular-Expression equal with Perl.\n} .
        qq{\n} .
        qq{<FILE>: specifies the input file name. If it is a standard input, "-" is given.\n} .
        qq{\n} .
        qq{<OPTIONS>\n} .
        qq{  -f [num-forward[,num-rear]]:\n} .
        qq{    It works like a filter program. If you omit the value,\n} .
        qq{    the default is to display 5 lines before and after.\n} .
        qq{    If you specify 0 for <num>, only lines that match <PATTERN> will be displayed.\n} .
        qq{    If you specify 0, grep is more convenient.\n} .
        qq{  -h, --no-filename:\n} .
        qq{    Suppress the prefixing of filenames on output when multiple files are searched.\n} .
        qq{  -H, --with-filename:\n} .
        qq{    Print the filename for each match.\n} .
        qq{  -i, --ignore-case:\n} .
        qq{    Ignore case distinctions in the <PATTERN>.\n} .
        qq{  -n, --line-number:\n} .
        qq{    Prefix each line of output with the line number within its input file.\n} .
        qq{  -c, --force-color:\n} .
        qq{    Enable highlighting even if STDOUT is not a TTY (pipe, redirect).\n} .
        qq{  -v, --version:\n} .
        qq{    Print the version of this script and Perl and exit.\n} .
        qq{  --help: Display this help and exit.\n} .
        qq{\n} .
        qq{Try "perldoc $main::apppath/$main::appname" for more information.\n};

    if( $_[0] ){
        print STDERR ( $msg );
    }else{
        print STDOUT ( $msg );
    }

    return 0;
}
__END__

=pod

=encoding utf8

=head1 NAME

MARK - emphasizes part matching a pattern

=head1 SYNOPSIS

$ mark [I<OPTIONS...>] I<PATTERN> [I<FILE...>]

=head1 DESCRIPTION

The "B<mark>" behaves like the marker pen.
The specified I<PATTERN> is searched out and that part is emphasized.

The I<PATTERN> can be described by the Regular-Expression equal with B<Perl>.

I<FILE> specifies the input file name.
If it is a standard input, "B<->" is given.

=head1 OPTIONS

=over 4

=item -d, --debug

Debugging mode is on.

=item -f [I<num-forward>[,I<num-rear>]]

It works like a filter program. If you omit the value,
the default is to display 5 lines before and after.
If you specify 0 for I<num>, only lines that match I<PATTERN> will be displayed.
If you specify 0, grep is more convenient.

=item --help

Display simple help and exit.

=item -v, --version

Print the version of this script and Perl and exit.

=item -h, --no-filename

Suppress the prefixing of filenames on output when multiple files are searched.

=item -H, --with-filename

Print the filename for each match.

=item -i, --ignore-case

Ignore case distinctions in the I<PATTERN>.

=item -n, --line-number

Prefix each line of output with the line number within its input file.

=item -c, --force-color

Enable highlighting even if STDOUT is not a TTY (pipe, redirect).

=back

=head1 ADVANCED USAGE

  $ rpm -qa | mark '-[0-9]+[a-z]?\..+$'

  $ mark '\b\d{1,3}(?:\.\d{1,3}){3}\b' /var/log/maillog

  $ mark -nf 5,0 '(ServerName|DocumentRoot|Log)\s+.*$' /etc/httpd/conf/httpd.conf

  $ mark -iHnf 0,10 '^[^\s].*$' *.{c,h}

  $ mark -ni '</?(table|tr|th|td)[^>]*>' index.html | S<less -R>

  $ man perlfunc | mark -nf 5,10 -i 'regular expr' | S<less -R>

  $ man awk | perl -ne 's/.\010//go; print' | S<mark -nf 0,3 '^[A-Z]'>

  $ tail -f /var/log/httpd/access_log | S<mark -f 0 '"(GET|POST) /(?:\S+(?:\.html|\.htm|/))? [^"]+"'>

  $ ls -tr /var/log/messages.?.gz | xargs gzip -dc | mark -ihf 10 'error' - /var/log/messages > /tmp/report.txt

=head1 DEPENDENCIES

This script uses only B<core Perl modules>. No external modules from CPAN are required.

=head2 Core Modules Used

=over 4

=item * L<File::Basename> — first included in perl 5

=item * L<strict> — first included in perl 5

=item * L<warnings> — first included in perl v5.6.0

=back

=head2 Survey methodology

=over 4

=item 1. Preparation

Define the script name:

  $ target_script=mark

=item 2. Extract used modules

Generate a list of modules from C<use> statements:

  $ grep '^use ' $target_script | sed 's!^use \([^ ;{][^ ;{]*\).*$!\1!' | \
      sort | uniq | tee ${target_script}.uselist

=item 3. Check core module status

Run C<corelist> for each module to find the first Perl version it appeared in:

  $ cat ${target_script}.uselist | while read line; do
      corelist $line
    done

=back

=head1 SEE ALSO

When you want to examine the regular expression,
please refer to an online manual of B<Perl>.

=over 4

=item L<perlre>(1)

Perl regular expressions

=item L<perlrequick>(1)

Perl regular expressions quick start

=item L<perlreref>(1)

Perl Regular Expressions Reference

=item L<perlretut>(1)

Perl regular expressions tutorial

=item L<perlfaq6>(1)

Regular Expressions

=item regex(7)

POSIX 1003.2 regular expressions

=back

Other more basic references

L<perl>(1), grep(1)

=head1 AUTHOR

2006-2025, tomyama

=head1 LICENSE

Copyright (c) 2006-2025, tomyama

All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.

2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation
   and/or other materials provided with the distribution.

3. Neither the name of tomyama nor the names of its contributors
   may be used to endorse or promote products derived from this software
   without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

=cut