# stdf4_survey.pl
# Copyright (C) 2005 Michael Hackerott. All Rights Reserved
#
# This program is free software; you can redistribute it and/or modify it
# under the terms of either the GNU General Public License or the Artistic
# License as specified in the Perl README file.
#
# 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 OWNER
# 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.
#
# This module is documented using POD in-line with the perl code and
# is extracted using the pod2html utility:
#
#	pod2html --infile=stdf4_survey.pl --outfile=stdf4_survey.html

=pod

=head1 NAME

stdf4_survey.pl - Surveys an STDF Version 4 file and outputs information
about the file contents to standard output.

=head1 SYNTAX

	perl stdf4_survey.pl [OPTIONS] ARGUMENTS

	OPTIONS

		-a, --about
			Displays information about this program.

		-d, --debug
			Enables debug mode which outputs debug information to
			standard output.

		-h, --help
			Displays help for this program.

		-l, --log
			Enables log mode which outputs log information to
			standard output.

	ARGUMENTS

		StdfFileSpec
			The input STDF file specification.

	RETURNS

		The program returns a value of unix true (0) if no errors
		occur; otherwise, a value of unix false (1) is returned.

	STANDARD INPUT

		Standard input is ignored.

	STANDARD OUTPUT

	STANDARD ERROR

		If an error occurs then a message is output to standard error.

=head1 SYNOPSIS

	perl stdf4_survey.pl -a
	perl stdf4_survey.pl --about

		Displays information about the program.

	perl stdf4_survey.pl -h
	perl stdf4_survey.pl --help

		Displays the help for the program.

	perl stdf4_survey.pl StdfFileSpec

		Surveys the STDF file specified by StdfFileSpec and outputs
		the survey results to standard output.

	perl stdf4_survey.pl -d StdfFileSpec
	perl stdf4_survey.pl --debug StdfFileSpec

		Surveys the STDF file specified by StdfFileSpec and outputs
		the survey results and debug information to standard output.

	NOTE: Use command line redirection to capture standard
	output to a file.

=head1 DESCRIPTION

This program surveys an STDF Version 4 file and outputs information about
the file contents to standard output.

=head2 Default Output

The default output consists of the a header and the survey of each
record in the STDF file.

A record survey consists of the record number (REC#), the absolute byte
offset of the record in the file (ABO), the hex value of the record
length (LENHEX), the decimal value of the record length (LENDEC), the
hex value of the record type (TYPHEX), the decimal value of the record
type (TYPDEC),the hex value of the record sub-type (SUBHEX), the decimal
value of the record sub-type (SUBDEC),the hex value of the record data
(DATHEX), the text of the record length (DATTXT).

NOTE: All control characters and ASCII characters equal to or greater
than decimal 126 are filtered and replaced by the ° character in the
text representation of the data.

	REC#	ABO	LENHEX	LENDEC	TYPHEX	TYPDEC	SUBHEX	SUBDEC	RECNAM	DATHEX	DATTXT
	1	0	0200	2	00	0	0A	10	FAR	0204	°°
	2	6	AA00	170	01	1	0A	10	MIR	72F3684372F3684300505920FFFF200C544A4D4541303336305930300D4D433953303847543630434644074A3735302D3038044A3735301046696E616C5F546573745F34347166700C39533038474236305F4A3035000548523236380549472D584C07332E34302E30390346434E032D34300000000D4D4339533038475436304346440003544A4E00044C3331520232300000114D4339533038475436304346445F46434E0439393939	r°hCr°hC°PY°°°°°TJMEA0360Y00°MC9S08GT60CFD°J750-08°J750°Final_Test_44qfp°9S08GB60_J05°°HR268°IG-XL°3.40.09°FCN°-40°°°°MC9S08GT60CFD°°TJN°°L31R°20°°°MC9S08GT60CFD_FCN°9999
	...
	4260	113748	0400	4	01	1	14	20	MRR	9C016943	°°iC

=head2 Additional Log Output

If the log mode is enabled then log information is output in addition to
the default output.

	stdf4_survey.pl Copyright (C) 2005 Michael Hackerott. All Rights Reserved
	STDF File Spec: ..\data\inp\STDF\FT_J750_112KB.stdf
	STDF File Size: 113756 bytes
	... <default output> ...
	Surveyed 113756 byte STDF file in 1 seconds (113756.0 bytes/second).

=head2 Additional Debug Output

If the debug mode is enabled then debug information is output in
addition to the default output. (NOTE: debug mode increases the survey
time and amount of output by approximately 15 to 25 times!)

	%gOptions = ('log' => 1,'debug' => 1);
	$gStdfFileSpec = '..\\data\\inp\\STDF\\FT_J750_112KB.stdf';
	$gStdfFileSize = 113756;
	REC#	ABO	LENHEX	LENDEC	TYPHEX	TYPDEC	SUBHEX	SUBDEC	RECNAM	DATHEX	DATTXT
	$gStdfFile{'ABO'} = 0;
	$gStdfRcrd{'LENBIN'} =
	  0000 00000010 02 2   ¤
	  0001 00000000 00 0   ¤
	$stdfRecordRead::status = 2;
	$gStdfRcrd{'LENHEX'} = '0200';
	$gStdfFile{'ENDIAN'} = 1;
	$stdfRecordRead::lenhex = '0002';
	$gStdfRcrd{'LENDEC'} = '2';
	$gStdfRcrd{'TYPBIN'} =
	  0000 00000000 00 0   ¤
	$gStdfRcrd{'TYPHEX'} = '00';
	$gStdfRcrd{'TYPDEC'} = 0;
	$gStdfRcrd{'SUBBIN'} =
	  0000 00001010 0A 10  ¤
	$gStdfRcrd{'SUBHEX'} = '0A';
	$gStdfRcrd{'SUBDEC'} = 10;
	$gStdfRcrdName = 'FAR';
	$gStdfRcrd{'DATBIN'} =
	  0000 00000010 02 2   ¤
	  0001 00000100 04 4   ¤
	$gStdfRcrd{'DATHEX'} = '0204';
	$gStdfRcrd{'DATTXT'} = '°°';
	1	0	0200	2	00	0	0A	10	FAR	0204	°°
	...

=cut

BEGIN
{
	unshift(
		@INC,
		'lib',
		'../lib'
	);
};

use TDF;

use strict;

######################################################################
# PROGRAM CONSTANT DECLARATIONS
######################################################################

# set the program name
my $PROGRAM = 'stdf4_survey.pl';

# set the version number
my $VERSION = '1.0.0';

use constant TRUE	=> 1;
use constant FALSE	=> 0;

use constant EOL	=> "\n";
use constant Q1	=> "\'";
use constant Q2	=> "\"";
use constant SPC	=> "\ ";
use constant TAB	=> "\t";

# @gStdfBR indexes
use constant REC_LEN => 0;
use constant REC_TYP => 1;
use constant REC_SUB => 2;
use constant REC_DAT => 3;

my %STDF_TO_ATDF_RECORD_SUBREF = (
	'ATR' => \&ATR,
	'BPS' => \&BPS,
	'DTR' => \&DTR,
	'EPS' => \&EPS,
	'FAR' => \&FAR,
	'FTR' => \&FTR,
	'GDR' => \&GDR,
	'HBR' => \&HBR,
	'MIR' => \&MIR,
	'MPR' => \&MPR,
	'MRR' => \&MRR,
	'PCR' => \&PCR,
	'PGR' => \&PGR,
	'PIR' => \&PIR,
	'PLR' => \&PLR,
	'PMR' => \&PMR,
	'PRR' => \&PRR,
	'PTR' => \&PTR,
	'RDR' => \&RDR,
	'SBR' => \&SBR,
	'SDR' => \&SDR,
	'TSR' => \&TSR,
	'WCR' => \&WCR,
	'WIR' => \&WIR,
	'WRR' => \&WRR,
);

######################################################################
# PROGRAM VARIABLE DECLARATIONS
######################################################################

my @gTimer = (time());

my %gOptions = (
	'debug'	=> FALSE,
	'log'	=> FALSE,
);

my $gStdfFileSpec = undef;
my $gStdfFileSize = undef;

# STDF Record Name
my $gStdfRcrdName = undef;

# STDF File Data
my %gStdfFile = (
	'RECNUM' => 0,
);

# STDF Record Data
my %gStdfRcrd = ();

######################################################################
# MAIN
######################################################################

# enable autoflush
$| = TRUE;

# process the unix command line options
while ($ARGV[0] =~ m/^\-/)
{
	my $option = shift(@ARGV);
	if ($option =~ m/^\-(a|\-about)/)
	{
		about();
	}
	elsif ($option =~ m/^\-(d|\-debug)/)
	{
		$gOptions{'debug'} = TRUE;
	}
	elsif ($option =~ m/^\-(h|\-help)/)
	{
		help();
	}
	elsif ($option =~ m/^\-(l|\-log)/)
	{
		$gOptions{'log'} = TRUE;
	};
};
dbugData([\%gOptions], ['*gOptions']);

loggText(
	$PROGRAM,
	'Copyright (C) 2005 Michael Hackerott.',
	'All Rights Reserved'
);

# get the ATDF file specification
$gStdfFileSpec = shift(@ARGV);
if ($gStdfFileSpec eq '')
{
	fatal('STDF file specification is not defined!');
}
elsif (! -f $gStdfFileSpec)
{
	fatal(
		'STDF file does not exist:',
		$gStdfFileSpec
	);
};
dbugData([$gStdfFileSpec], ['*gStdfFileSpec']);
loggText('STDF File Spec:', $gStdfFileSpec);

$gStdfFileSize = (-s $gStdfFileSpec);
dbugData([$gStdfFileSize], ['*gStdfFileSize']);
loggText('STDF File Size:', $gStdfFileSize, 'bytes');

# open the STDF file for read as binary
if (! open(FILE_STDF, '<'.$gStdfFileSpec))
{
	fatal(
		'Failed to open for read STDF file:',
		$gStdfFileSpec
	);
};
binmode(FILE_STDF);

# print the survey head
print(join(TAB,
	'REC#',
	'ABO',
	'LENHEX',
	'LENDEC',
	'TYPHEX',
	'TYPDEC',
	'SUBHEX',
	'SUBDEC',
	'RECNAM',
	'DATHEX',
	'DATTXT',
).EOL);

#
# READ THE FIRST RECORD IN THE STDF FILE AND TEST TO
# VALIDATE THAT IT IS AN FAR RECORD
#

# read the first STDF record
stdfRecordRead();

# process the first STDF record
FAR();

# print the survey data to STDOUT
printSurvey();

#
# PROCESS THE REST OF THE STDF FILE RECORDS
#

# read the STDF file
while (! eof(FILE_STDF))
{
	# read the next STDF record
	stdfRecordRead();

	# convert the STDF record data fields to ATDF
	$STDF_TO_ATDF_RECORD_SUBREF{$gStdfRcrdName}->();

	# print the survey data to STDOUT
	printSurvey();
};

# close the STDF file
close(FILE_STDF);

# set the timer
$gTimer[1] = time();

# logg conversion
my $seconds = ($gTimer[1] - $gTimer[0]) || 1;
my $bytesPerSecond = $gStdfFileSize / $seconds;
loggText(sprintf(
	'Surveyed %d byte STDF file in %d seconds (%.1f bytes/second).',
	$gStdfFileSize,
	$seconds,
	$bytesPerSecond
));

# exit to unix without error
exit(0);

######################################################################
# SUBROUTINES
######################################################################

# about()

sub about
{
	TDF::about('stdf4_survey.pl', $VERSION)
};

# $status = dbugEnabled()

sub dbugEnabled
{
	return($gOptions{'debug'});
};

# dbugData(dbugData(\@varRefs, \@varNames))

sub dbugData
{
	dbugEnabled() && TDF::dbugData(@_);
};

# dbugDataBin($datnam, $bindat)

sub dbugDataBin
{
	dbugEnabled() && TDF::dbugDataBin(@_);
};

# dbugDataPurdy(\@varRefs, \@varNames)

sub dbugDataPurdy
{
	dbugEnabled() && TDF::dbugDataPurdy(@_);
};

# dbugSub($subname, @_)

sub dbugSub
{
	dbugEnabled() && TDF::dbugSub(@_);
};

# dbugText(@text)

sub dbugText
{
	dbugEnabled() && TDF::dbugText(@_);
};

# help()

sub help
{
	print <<"END_HELP";
SEE ALSO

	The program documentation for additional information.
END_HELP

	# exit to unix without error
	exit(0);
};

# $status = loggEnabled()

sub loggEnabled
{
	return($gOptions{'log'});
};

# $status = loggText(@text)

sub loggText
{
	loggEnabled() && print(join(SPC, @_).EOL);
};

# printSurvey()

sub printSurvey
{
	my @survey = (
		$gStdfFile{'RECNUM'},
		$gStdfFile{'ABO'},
		$gStdfRcrd{'LENHEX'},
		$gStdfRcrd{'LENDEC'},
		$gStdfRcrd{'TYPHEX'},
		$gStdfRcrd{'TYPDEC'},
		$gStdfRcrd{'SUBHEX'},
		$gStdfRcrd{'SUBDEC'},
		$gStdfRcrdName,
		$gStdfRcrd{'DATHEX'},
		$gStdfRcrd{'DATTXT'}
	);
	print(join(TAB, @survey).EOL);
};

# $status = scrubNonPrintChars(\$text)
#
# WARNING: this subroutine modifies the text value in place replacing
# the original contents with the scrubbed contents!

sub scrubNonPrintChars
{
	# get subroutine argument(s)
	my $rsText = shift();

	# define local variables
	my $i = undef; # current record index
	my $n = undef; # number of records in the list
	my $statusBS = FALSE; # backspace status: default is not scrubbed
	my $statusNP = FALSE; # non-print status: default is not scrubbed

	# convert the text string to a list of characters
	my @text = split(//, ${$rsText});

	# get the index of the last element in the list
	$n = $#text;

	# scrub each record in the list
	for $i (0 .. $n)
	{
		# process the special case 'backspace' character where
		# not only the non-printing backspace character must be
		# deleted but also the character preceeding the backspace
		# character.
		while ($text[$i] =~ s/(.\x08){1}/\xB0/) {$statusBS = 1;};

		# test if the scalar contains: NUL, SOH, STX,
		# ETX, EOT, ENQ, ACK, BEL, BS, VT, FF, SO, SI, DLE, DC1, DC2, DC3
		# DC4, NAK, SYN, ETB, CAN, EM, SUB, ESC, FS, GS, RS, US, or any
		# ASCII character in the range of hex 7F to FF and delete them.
		#$statusNP = ($text[$i] =~ s/[\x00-\x07\x0B-\x0C\x0E-\x1F\x7F-\xFF]/\xB0/g);
		$statusNP = ($text[$i] =~ s/[\x00-\x20\x7F-\xFF]/\xB0/g);
	};

	# set the text to the scrubbed value
	${$rsText} = join('', @text);

	# return scrub status
	return($statusBS || $statusNP);
};

# stdfRecordRead()

sub stdfRecordRead
{
	# declare local variables
	%gStdfRcrd = ();

	# get the STDF file byte offset
	$gStdfFile{'ABO'} = tell(FILE_STDF);
	dbugData([$gStdfFile{'ABO'}], ["*gStdfFile{'ABO'}"]);

	# read REC_LEN U*2
	my $status = read(FILE_STDF, $gStdfRcrd{'LENBIN'}, 2);
	dbugDataBin("\$gStdfRcrd{'LENBIN'}", $gStdfRcrd{'LENBIN'});
	dbugData([$status], ['*stdfRecordRead::status']);

	# unpack REC_LEN U*2 as hex
	$gStdfRcrd{'LENHEX'} = uc(unpack('H4', $gStdfRcrd{'LENBIN'}));
	dbugData([$gStdfRcrd{'LENHEX'}], ["\$gStdfRcrd{'LENHEX'}"]);

	# test for first record in file
	if ($gStdfFile{'ABO'} == 0)
	{
		# determine endian
		$gStdfFile{'ENDIAN'} = 0; # LITTLE
		if ($gStdfRcrd{'LENHEX'} eq '0200')
		{
			$gStdfFile{'ENDIAN'} = 1; # BIG
		};
		dbugData([$gStdfFile{'ENDIAN'}], ["\$gStdfFile{'ENDIAN'}"]);
	};

	# unpack REC_LEN U*1 as dec
	my $lenhex = $gStdfRcrd{'LENHEX'};
	if ($gStdfFile{'ENDIAN'} == 1) # BIG ENDIAN
	{
		$lenhex = substr($lenhex, 2, 2).substr($lenhex, 0, 2);
	};
	dbugData([$lenhex], ['$stdfRecordRead::lenhex']);
	$gStdfRcrd{'LENDEC'} = hex('0x'.$lenhex);
	dbugData([$gStdfRcrd{'LENDEC'}], ["\$gStdfRcrd{'LENDEC'}"]);

	# read REC_TYP U*1
	read(FILE_STDF, $gStdfRcrd{'TYPBIN'}, 1);
	dbugDataBin("\$gStdfRcrd{'TYPBIN'}", $gStdfRcrd{'TYPBIN'});

	# unpack REC_TYP U*1 as hex
	$gStdfRcrd{'TYPHEX'} = uc(unpack('H2', $gStdfRcrd{'TYPBIN'}));
	dbugData([$gStdfRcrd{'TYPHEX'}], ["\$gStdfRcrd{'TYPHEX'}"]);

	# unpack REC_TYP U*1 as dec
	$gStdfRcrd{'TYPDEC'} = unpack('C', $gStdfRcrd{'TYPBIN'});
	dbugData([$gStdfRcrd{'TYPDEC'}], ["\$gStdfRcrd{'TYPDEC'}"]);

	# read REC_SUB U*1
	read(FILE_STDF, $gStdfRcrd{'SUBBIN'}, 1);
	dbugDataBin("\$gStdfRcrd{'SUBBIN'}", $gStdfRcrd{'SUBBIN'});

	# unpack REC_SUB U*1 as hex
	$gStdfRcrd{'SUBHEX'} = uc(unpack('H2', $gStdfRcrd{'SUBBIN'}));
	dbugData([$gStdfRcrd{'SUBHEX'}], ["\$gStdfRcrd{'SUBHEX'}"]);

	# unpack REC_SUB U*1 as dec
	$gStdfRcrd{'SUBDEC'} = unpack('C', $gStdfRcrd{'SUBBIN'});
	dbugData([$gStdfRcrd{'SUBDEC'}], ["\$gStdfRcrd{'SUBDEC'}"]);

	# set the STDF record name
	$gStdfRcrdName = stdfRecordTypeCodesToName(
		$gStdfRcrd{'TYPDEC'},
		$gStdfRcrd{'SUBDEC'}
	);
	dbugData([$gStdfRcrdName], ['*gStdfRcrdName']);

	# test the STDF record name
	if ($gStdfRcrdName eq '')
	{
		fatal(
			'Unknown header',
			'record type', $gStdfRcrd{'TYPDEC'},
			'and/or',
			'record sub-type', $gStdfRcrd{'SUBDEC'},
			'at byte offset', $gStdfFile{'ABO'},
			'in STDF file', $gStdfFileSpec
		);
	};

	# read the STDF record data
	read(FILE_STDF, $gStdfRcrd{'DATBIN'}, $gStdfRcrd{'LENDEC'});
	dbugDataBin("\$gStdfRcrd{'DATBIN'}", $gStdfRcrd{'DATBIN'});

	# unpack STDF record data as hex
	$gStdfRcrd{'DATHEX'} = uc(unpack('H*', $gStdfRcrd{'DATBIN'}));
	dbugData([$gStdfRcrd{'DATHEX'}], ["\$gStdfRcrd{'DATHEX'}"]);

	# unpack STDF record data as hex
	$gStdfRcrd{'DATTXT'} = unpack('A*', $gStdfRcrd{'DATBIN'});
	scrubNonPrintChars(\$gStdfRcrd{'DATTXT'});
	dbugData([$gStdfRcrd{'DATTXT'}], ["\$gStdfRcrd{'DATTXT'}"]);

	# count the read records
	$gStdfFile{'RECNUM'} += 1;
};

#=====================================================================
# STDF TO ATDF RECORD SUBROUTINES
#=====================================================================

# ATR()

sub ATR
{
};

# BPS()

sub BPS
{
};

# DTR()

sub DTR
{
};

# EPS()

sub EPS
{
};

# FAR()

sub FAR
{
};

# FTR()

sub FTR
{
};

# GDR()

sub GDR
{
};

# HBR()

sub HBR
{
};

# MIR()

sub MIR
{
};

# MPR()

sub MPR
{
};

# MRR()

sub MRR
{
};

# PCR()

sub PCR
{
};

# PGR()

sub PGR
{
};

# PIR()

sub PIR
{
};

# PLR()

sub PLR
{
};

# PMR()

sub PMR
{
};

# PRR()

sub PRR
{
};

# PTR()

sub PTR
{
};

# RDR()

sub RDR
{
};

# SBR()

sub SBR
{
};

# SDR()

sub SDR
{
};

# TSR()

sub TSR
{
};

# WCR()

sub WCR
{
};

# WIR()

sub WIR
{
};

# WRR()

sub WRR
{
};

######################################################################

=pod

=head1 REQUIRES

E<bull> Perl 5.6 or newer.

E<bull> Perl core module strict.

E<bull> Perl custom module TDF.pm.

=head1 SEE ALSO

E<bull> perl core and module documentation.

E<bull> STDF Specification V4 published by Teradyne, Inc.

E<bull> ATDF Specification V2 published by Teradyne, Inc.

=head1 AUTHORS

E<bull> Michael Hackerott, michael.hackerott@mrhackerott.org

=head1 COPYRIGHT

Copyright E<copy> 2004-2005 Michael Hackerott. All rights reserved.

This program is free software; you can redistribute it and/r modify it
under the terms of either the GNU General Public License or the Artistic
License as specified in the Perl README file.

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 OWNER
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.

=head1 ACKNOWLEDGEMENT

The Standard Test Data Format (STDF) and ASCII Test Data Format (ATDF)
specifications are the original works of Teradyne Inc.

=head1 KNOWN BUGS

=head1 HISTORY

1.0.0 (200512031456) Michael Hackerott

E<bull>  Created program.

=cut

__END__