source: app/src/tok/tok @ 25ae32e

#!/usr/bin/perl

use locale;
use Getopt::Long;

my $interactive=0;
my $help;

my $configfile1=".../../conf/tok.conf";
my $configfile2="../conf/tok.conf";

#read configuration files###########################
my $file;
foreach $file ($configfile1, $configfile2){
        if(open(CONFIG, $configfile1)){
                while (<CONFIG>) {
                        chomp;                  
                        s/#.*//;                
                        s/^\s+//;               
                        s/\s+$//;               
                        next unless length;     
                        my ($name, $value) = split(/\s*=\s*/, $_, 2);
                        if(($name eq "interactive")or($name eq "i")){
                                $interactive=1;
                        }
                        elsif(($name eq "help")or($name eq "h")){
                                $help=1;
                        }
                } 
                close CONFIG;
        }
}
#########################################################s

GetOptions("interactive|i" => \$interactive,
           "help|h" => \$help);

if($help)
{
    print <<'END'
Usage: tok [OPTIONS]

Options:
   --interactive                Interactive (no output buffering).
   --help -h                    Help.
END
;
    exit 0;
}


$| = $interactive;

my $offset = 0;

while(<>)
{
    1 while  
        / [[:alpha:]]+   (?{seg('W',$&)})
        | \d+            (?{seg('N',$&)})
        | \s+            (?{seg('S',$&)})
        | [[:punct:]]    (?{seg('P',$&)})
        | .              (?{seg('B',$&)})
        /gxo;
}

#       | [^[:print:]]   (?{seg("B",$&)})


sub seg
{
    my ($tag,$match) = @_;
    my $len=length $match;
    printf "%04d %02d %s ", $offset, $len, $tag;
    if($tag eq 'S')
    {
        for(my $i=0; $i<$len; ++$i)
        {
            my $c = substr $match, $i, 1;
            print '_' if $c eq ' ';
            print '\n' if $c eq "\n";
            print '\t' if $c eq "\t";
            print '\r' if $c eq "\r";
            print '\f' if $c eq "\f";
        }
    }
    elsif($tag eq 'B')
    {
        printf "\\x%02X", ord($match);
    }
    else
    {
        print $match;
    }
    print "\n";
    $offset += $len;
}