[13787] in Perl-Users-Digest
Perl-Users Digest, Issue: 1197 Volume: 9
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Wed Oct 27 23:12:45 1999
Date: Wed, 27 Oct 1999 20:12:32 -0700 (PDT)
From: Perl-Users Digest <Perl-Users-Request@ruby.OCE.ORST.EDU>
To: Perl-Users@ruby.OCE.ORST.EDU (Perl-Users Digest)
Message-Id: <941080352-v9-i1197@ruby.oce.orst.edu>
Content-Type: text
Perl-Users Digest Wed, 27 Oct 1999 Volume: 9 Number: 1197
Today's topics:
Req. for comments on approach <scottlm@visi.com>
Re: Request style comments (code included - longish) (Abigail)
Re: Request style comments (code included - longish) <gellyfish@gellyfish.com>
Review request! Does this module seem useful/correct? (Clinton Pierce)
Re: Review request! Does this module seem useful/corre (M.J.T. Guy)
Re: Review request! Does this module seem useful/corre (Clinton Pierce)
Re: Review request! Does this module seem useful/corre <aqumsieh@matrox.com>
Re: Review request! Does this module seem useful/correc (Neko)
Re: robust telnet solution? <cassell@mail.cor.epa.gov>
Re: robust telnet solution? <rootbeer@redcat.com>
Re: robust telnet solution? <corlando@MUNGEpop.phnx.uswest.net>
Re: robust telnet solution? <rootbeer@redcat.com>
Digest Administrivia (Last modified: 16 Sep 99) (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: Wed, 27 Oct 1999 11:04:50 -0500
From: Scott McGerik <scottlm@visi.com>
Subject: Req. for comments on approach
Message-Id: <381722A2.AED5B97E@visi.com>
After searching for a Perl module that handles ANSI X12N files, I
decided to build my own module. It is necessary that I build a robust
module that will determine if the file is correctly structured. I have
included my code that does such below. I have included it because I
desire constructive criticism so that I may improve the code.
First, some background information. ANSI X12N files are a group of
file formats relating to EDI and the insurance industry. In
particular, I am interested in Health Care Claim (837) and Health Care
Claim Payment/Advice (835) files, as I work for a non-profit HMO.
These files have a particular structure to them. The contain many
records, called segments, that may or may not be mandatory. These
records may repeat as necessary and as specified by the standard.
These segments must occur in the specified order, if they appear.
These segments are grouped into loops, which may or may not be
mandatory and which may repeat as necessary and as specified by the
standard. Loops may be nested in other loops. These loops must appear
in the specified order, if they appear. With that in mind, below is
the structure of an 835 v003050 (version 3050).
Segment Requirement Maximum Loop
ID Designation Use Repeat
Loop ID - ST >1
--------------------------------------------------+
ST Mandatory 1 N/A |
BPR M 1 N/A |
NTE Optional >1 N/A |
TRN O 1 N/A |
CUR O 1 N/A |
REF O >1 N/A |
DTM O >1 N/A |
------------------------------------------------+ |
Loop Id - N1 200 | |
N1 O 1 N/A | |
N2 O >1 N/A | |
N3 O >1 N/A | |
N4 O 1 N/A | |
REF O >1 N/A | |
PER O >1 N/A | |
------------------------------------------------+ |
------------------------------------------------+ |
Loop ID - LX >1 | |
LX O 1 N/A | |
TS3 O 1 N/A | |
TS2 O 1 N/A | |
----------------------------------------------+ | |
Loop ID - CLP >1 | | |
CLP M 1 N/A | | |
CAS M 99 N/A | | |
NM1 M 9 N/A | | |
MIA O 1 N/A | | |
MOA O 1 N/A | | |
REF O 99 N/A | | |
DTM O 9 N/A | | |
PER O 3 N/A | | |
AMT O 20 N/A | | |
QTY O 20 N/A | | |
--------------------------------------------+ | | |
Loop ID - SVC 999 | | | |
SVC O 1 N/A | | | |
DTM O 9 N/A | | | |
CAS O 99 N/A | | | |
REF O 99 N/A | | | |
AMT O 20 N/A | | | |
QTY O 20 N/A | | | |
--------------------------------------------+-+-+ |
PLB O 99 N/A |
SE M 1 N/A |
--------------------------------------------------+
In the above table, Loops N1 and LX are nested within Loop ST.
Loop CLP is nested within Loop LX.
Loop SVC is nested within Loop CLP.
Segments, or records, have a defined structure that allows them to be
somewhat generic. Thus a segment, such as the REF segment (Reference
Numbers) may appear in many locations in a file and may appear more
than once, in a sequence.
A loop is mandatory if the first segment of a loop is mandatory, thus
Loop CLP is mandatory because segment CLP is mandatory.
With the Perl code below, I have attempted to code a program that will
read in template of the file and the file in question, and step
through both (the template and the file). The program attempts to
verify that the input file does in fact conform to the specified
template.
The code below does work. I am currently using it to process 837's and
835's. I am looking for suggestions on how to improve the code. If
there appears to be enough interest, I might release it as a module to
CPAN.
Scott McGerik.
---Begin Perl code---
# arrays beginning with 'Loop' indicate a loop start
# ('Loop', Loop ID, Loop Repeat) (zero (0) indicates no maximum value)
# arrays beginning with something other than 'Loop' indicate segments
# (Seg ID, Max Use, Req. Designator, Seq. No)
my $HCv3051 = [
['Loop', 'ST', 0,
['ST', 1, 1, '005'],
['BGN', 1, 0, '010'],
['REF', 3, 0, '015'],
['Loop', '1000', 10,
['NM1', 1, 0, '020'],
['N2', 2, 0, '025'],
['N3', 2, 0, '030'],
['N4', 1, 0, '035'],
['REF', 2, 0, '040'],
['PER', 2, 0, '045'],
],
['Loop', '2000', 0,
['PRV', 1, 1, '005'],
['CUR', 1, 0, '010'],
['Loop', '2010', 2,
['NM1', 1, 0, '015'],
['N2', 2, 0, '020'],
['N3', 2, 0, '025'],
['N4', 1, 0, '030'],
['REF', 20, 0, '035'],
['PER', 2, 0, '040'],
],
['Loop', '2100', 0,
['SBR', 1, 1, '045'],
['DTP', 5, 0, '050'],
['Loop', '2110', 10,
['NM1', 1, 0, '055'],
['N2', 2, 0, '060'],
['N3', 2, 0, '065'],
['N4', 1, 0, '070'],
['DMG', 1, 0, '075'],
['PER', 2, 0, '080'],
['REF', 5, 0, '085'],
],
['Loop', '2200', 99,
['PAT', 1, 1, '090'],
['Loop', '2210', 10,
['NM1', 1, 0, '095'],
['N2', 2, 0, '100'],
['N3', 2, 0, '105'],
['N4', 1, 0, '110'],
['DMG', 1, 0, '115'],
['PER', 2, 0, '120'],
['REF', 5, 0, '125'],
],
['Loop', '2300', 100,
['CLM', 1, 1, '130'],
['DTP', 150, 0, '135'],
['CL1', 1, 0, '140'],
['DN1', 1, 0, '145'],
['DN2', 35, 0, '150'],
['PWK', 10, 0, '155'],
['CN1', 1, 0, '160'],
['DSB', 1, 0, '165'],
['UR', 1, 0, '170'],
['AMT', 40, 0, '175'],
['REF', 30, 0, '180'],
['K3', 10, 0, '185'],
['NTE', 20, 0, '190'],
['CR1', 1, 0, '195'],
['CR2', 1, 0, '200'],
['CR3', 1, 0, '205'],
['CR4', 3, 0, '215'],
['CR5', 1, 0, '216'],
['CR6', 1, 0, '219'],
['CR8', 1, 0, '220'],
['CRC', 100, 0, '231'],
['HI', 25, 0, '240'],
['QTY', 10, 0, '241'],
['HCP', 1, 0, '242'],
['Loop', '2305', 6,
['CR7', 1, 0, '243'],
['HSD', 12, 0, '245'],
],
['LS', 1, 0, '2'],
['Loop', '2310', 9,
['NM1', 1, 0, '250'],
['PRV', 1, 0, '255'],
['N2', 2, 0, '260'],
['N3', 2, 0, '265'],
['N4', 1, 0, '270'],
['REF', 20, 0, '271'],
['PER', 2, 0, '275'],
],
['LE', 1, 0, '280'],
['LS', 1, 0, '285'],
['Loop', '2320', 10,
['SBR', 1, 0, '290'],
['CAS', 1, 0, '295'],
['AMT', 15, 0, '300'],
['DMG', 1, 0, '305'],
['OI', 1, 0, '310'],
['MIA', 1, 0, '315'],
['MOA', 1, 0, '320'],
['Loop', '2330', 10,
['NM1', 1, 0, '325'],
['N2', 2, 0, '330'],
['N3', 2, 0, '332'],
['N4', 1, 0, '340'],
['PER', 2, 0, '345'],
['DTP', 9, 0, '350'],
['REF', 8, 0, '355'],
],
['LE', 1, 0, '360'],
['Loop', '2400', 0,
['LX', 1, 0, '365'],
['SV1', 1, 0, '370'],
['SV2', 1, 0, '375'],
['SV3', 1, 0, '380'],
['TOO', 32, 0, '382'],
['SV4', 1, 0, '385'],
['SV5', 1, 0, '400'],
['SV6', 1, 0, '405'],
['SV7', 1, 0, '410'],
['HI', 25, 0, '415'],
['PWK', 10, 0, '420'],
['CR1', 1, 0, '425'],
['CR2', 5, 0, '430'],
['CR3', 1, 0, '435'],
['CR4', 3, 0, '440'],
['REF', 20, 0, '441'],
['CR5', 1, 0, '445'],
['CRC', 3, 0, '450'],
['DTP', 15, 0, '455'],
['QTY', 5, 0, '460'],
['CN1', 1, 0, '465'],
['REF', 30, 0, '470'],
['AMT', 15, 0, '475'],
['K3', 10, 0, '480'],
['NTE', 10, 0, '485'],
['PS1', 1, 0, '490'],
['HCP', 1, 0, '492'],
['Loop', '2410', 10,
['LIN', 1, 0, '493'],
['CTP', 1, 0, '494'],
],
['LS', 1, 0, '495'],
['Loop', '2420', 10,
['NM1', 1, 0, '500'],
['PRV', 1, 0, '505'],
['N2', 2, 0, '510'],
['N3', 2, 0, '514'],
['N4', 1, 0, '520'],
['REF', 20, 0, '525'],
['PER', 2, 0, '530'],
],
['LE', 1, 0, '535'],
['Loop', '2430', 0,
['SVD', 1, 0, '540'],
['CAS', 99, 0, '545'],
['DTP', 9, 0, '550'],
],
],
],
],
],
],
],
['SE', 1, 1, '555'],
],
['GE', 1, 1],
['IEA', 1, 1],
];
my $HRv3051 = [
['Loop', 'ST', 1,
['ST', 1, 1, '010'],
['BPR', 1, 1, '020'],
['NTE', 0, 0, '030'],
['TRN', 1, 0, '040'],
['CUR', 1, 0, '050'],
['REF', 0, 0, '060'],
['DTM', 0, 0, '070'],
['Loop', 'N1', 200,
['N1', 1, 0, '080'],
['N2', 0, 0, '090'],
['N3', 0, 0, '100'],
['N4', 1, 0, '110'],
['REF', 0, 0, '120'],
['PER', 0, 0, '130'],
],
['Loop', 'LX', 0,
['LX', 1, 0, '003'],
['TS3', 1, 0, '005'],
['TS2', 1, 0, '007'],
['Loop', 'CLP', 0,
['CLP', 1, 1, '010'],
['CAS', 99, 1, '020'],
['NM1', 9, 1, '030'],
['MIA', 1, 0, '033'],
['MOA', 1, 0, '035'],
['REF', 99, 0, '040'],
['DTM', 9, 0, '050'],
['PER', 3, 0, '060'],
['AMT', 20, 0, '062'],
['QTY', 20, 0, '064'],
['Loop', 'SVC', 999,
['SVC', 1, 0, '070'],
['DTM', 9, 0, '080'],
['CAS', 99, 0, '090'],
['REF', 99, 0, '100'],
['AMT', 20, 0, '110'],
['QTY', 20, 0, '120'],
['LQ', 99, 0, '130'],
],
],
],
['PLB', 99, 0, '010'],
['SE', 1, 1, '020'],
],
['GE', 1, 1],
['IEA', 1, 1],
];
# BE - Benefit Enrollment and Maintenance (834)
# FA - Functional Acknowledgment (997)
# HB - Health Care Eligibility/Benefit Information (271)
# HC - Health Care Claim (837)
# HI - Health Care Service Review Information (278)
# HN - Health Care Claim Status Notification (277)
# HP - Health Care Claim Payment/Advice (835)
# HR - Health Care Claim Status Request (276)
# HS - Health Care Eligibility/Benefit Inquiry (270)
$Templates = {
'HC' => {
'003051' => $HCv3051,
},
'HP' => {
'003051' => $HRv3051,
},
};
sub Parse {
# protect the current value of $ARG ($_)
local $ARG;
# get the name of the file in question
my $file = shift @ARG;
# get the rest of the arguments
my %args = @ARG;
# get the optional record separator
my $rs = $args{'rs'} if $args{'rs'};
# get the optional element separator
my $es = $args{'es'} if $args{'rs'};
# get the optional subelement separator
my $ses = $args{'ses'} if $args{'ses'};
# get the separators
($ses, $es, $rs) = Separators $file unless ($rs and $es and $ses);
local *TheSub;
if ( $args{'sub'} and ref $args{'sub'} eq 'CODE' ) {
*TheSub = $args{'sub'};
} # end of if $args{'sub'} and ref $args{'sub'} eq 'CODE'
# parse the file name
my $name = basename $file;
# open the file in read mode
unless ( open FILE, "<$file" ) {
# failure
# set the status message
message "Unable to parse '$name'. Unable to open '$name' in read
mode. $ERRNO";
# return failure
return $failure;
} # end of unless open FILE, "<$file"
local *GetNextSegment = sub {
local $RS = $rs;
# loop forever
while ( 1 ) {
# return undef if at the end of the file
return undef if eof FILE;
# get the next segment
my $Segment = <FILE>;
# remove the line endings
chomp $Segment;
# remove any embedded newlines and return chars
$Segment =~ s/[\n\r]+//g;
# get the next segment, this one is empty
next if length $Segment == 0;
# split the record into its elements
my @elements = split quotemeta($es), $Segment;
print STDERR $elements[0], "\n";
# return the data
return \@elements;
} # end of while
}; # end of sub GetNextRecord
# declare necessary variables
my $Segment = GetNextSegment();
my @ThisLoop;
my $ExpectedSegment = '';
my @OuterLoopStack;
my @CurrentLoopStack;
my $SegmentCount = 0;
my $LoopCount = 0;
my $MaxLoopRepeat;
my $LoopID;
my $ID = 0;
my $MaxUse = 1;
my $Required = 2;
my $SeqNo = 3;
# iterate over the segments
while ( 1 ) {
# at the end of a nested loop
unless ( defined $ExpectedSegment ) {
# is there anything on the stack and does the top of the stack
correspond to the current segment?
if ( $CurrentLoopStack[$#CurrentLoopStack] and $Segment->[$ID]
eq $CurrentLoopStack[$#CurrentLoopStack][3][$ID] ) {
# yes, reload the current loop and restart at the top of the loop
# increment the count for this loop
$LoopCount++;
# get the current level
@ThisLoop = @{$CurrentLoopStack[$#CurrentLoopStack]};
# discard the 'Loop' indicator
shift @ThisLoop;
# get the loop ID
$LoopID = shift @ThisLoop;
# get the max loop repeat value
$MaxLoopRepeat = shift @ThisLoop;
# too many iterations of this loop?
if ( $MaxLoopRepeat and $LoopCount > $MaxLoopRepeat ) {
# yes
# set the status message
message "parse error. max loop repeat violation. Loop ID $LoopID.
Max Loop Repeat $MaxLoopRepeat.";
# return failure
return $failure;
} # end of if $LoopCount > $MaxLoopRepeat
# get the next segment template
$ExpectedSegment = shift @ThisLoop;
# start at the top of the loop again
next;
} # end of if $Segment->[$ID] eq
$CurrentLoopStack[$#CurrentLoopStack][3][$ID]
# is it the GE segment?
if ( $Segment->[$ID] eq 'GE' ) {
# GE - Functional Group Trailer
# get the next segment from the data file
unless ( defined($Segment = GetNextSegment()) ) {
# no
# set the status message
message "no more data to parse.";
# return success
return $success;
} # end of unless defined $Segment
# start at the top of the loop again
next;
} # end of if $Segment->[$ID] eq 'GE'
# is it the ISE segment?
if ( $Segment->[$ID] eq 'IEA' ) {
# IEA - Interchange Control Trailer
# is there any more data?
unless ( defined($Segment = GetNextSegment()) ) {
# no
# set the status message
message "no more data to parse.";
# return success
return $success;
} # end of unless defined $Segment
# start at the top of the loop again
next;
} # end of if $Segment->[$ID] eq 'IEA'
# is it the ISA segment?
if ( $Segment->[$ID] eq 'ISA' ) {
# ISA - Interchange Control Header
# get the next segment from the data file
unless ( defined($Segment = GetNextSegment()) ) {
# no
# set the status message
message "no more data to parse.";
# return success
return $success;
} # end of unless defined $Segment
# start at the top of the loop again
next;
} # end of if $Segment->[$ID] eq 'ISA'
# is it the GS segment?
if ( $Segment->[$ID] eq 'GS' ) {
# GS - Functional Group Header
# is element GS01 present?
unless ( $Segment->[1] ) {
# no, it is not present
# set the status message
message "Unable to get the Functional ID Code. Missing data in the
GS segment.";
# return failure
return $failure;
} # end of unless $Segment->[1]
# is element GS08 present?
unless ( $Segment->[8] ) {
# no, it is not present
# set the status message
message "Unable to get the Version/Release/Industry Identifier
Code. Missing data in the GS segment.";
# return failure
return $failure;
} # end of unless $Segment->[8]
# get the template for this file
@ThisLoop = @{$Templates->{$Segment->[1]}{$Segment->[8]}};
# get the data for the expected segment
$ExpectedSegment = shift @ThisLoop;
# get the next segment from the data file
unless ( defined($Segment = GetNextSegment()) ) {
# no
# set the status message
message "no more data to parse.";
# return success
return $success;
} # end of unless defined $Segment
# start at the top of the loop again
next;
} # end of if $Segment->[$ID] eq 'GS'
# check to see if there is something on the stack
unless ( scalar @OuterLoopStack ) {
# the stack is empty
# set the status message
message "Parse error. empty stack";
# return failure
return $failure;
} # end of unless scalar @OuterLoopStack
# discard the stashed current loop structure
pop @CurrentLoopStack;
# get the stashed outer loop structure
@ThisLoop = @{pop @OuterLoopStack};
# get the next segment data
$ExpectedSegment = shift @ThisLoop;
# start at the top of the loop again
next;
} # end of unless defined $ExpectedSegment->[$ID]
# is it the ISA segment?
if ( $Segment->[$ID] eq 'ISA' ) {
# ISA - Interchange Control Header
# get the next segment from the data file
unless ( defined($Segment = GetNextSegment()) ) {
# no
# set the status message
message "no more data to parse.";
# return success
return $success;
} # end of unless defined $Segment
# start at the top of the loop again
next;
} # end of if $Segment->[$ID] eq 'ISA'
# is it the GS segment?
if ( $Segment->[$ID] eq 'GS' ) {
# GS - Functional Group Header
# is element GS01 present?
unless ( $Segment->[1] ) {
# no, it is not present
# set the status message
message "Unable to get the Functional ID Code. Missing data in the GS
segment.";
# return failure
return $failure;
} # end of unless $Segment->[1]
# is element GS08 present?
unless ( $Segment->[8] ) {
# no, it is not present
# set the status message
message "Unable to get the Version/Release/Industry Identifier Code.
Missing data in the GS segment.";
# return failure
return $failure;
} # end of unless $Segment->[8]
# get the template for this file
@ThisLoop = @{$Templates->{$Segment->[1]}{$Segment->[8]}};
# get the data for the expected segment
$ExpectedSegment = shift @ThisLoop;
# get the next segment from the data file
unless ( defined($Segment = GetNextSegment()) ) {
# no
# set the status message
message "no more data to parse.";
# return success
return $success;
} # end of unless defined $Segment
# start at the top of the loop again
next;
} # end of if $Segment->[$ID] eq 'GS'
# at the beginning of a loop
if ( $ExpectedSegment->[$ID] eq 'Loop' ) {
# increment the count for this loop
$LoopCount = 1;
# make a copy of this loop
my @Copy = @ThisLoop;
# save a copy of the current loop template on the outer loop
stack
push @OuterLoopStack, \@Copy;
# make a copy of the inner loop template
my @Inner = @$ExpectedSegment;
# save a copy current loop on the current loop stack
push @CurrentLoopStack, \@Inner;
# get the inner loop structure
@ThisLoop = @$ExpectedSegment;
# remove the 'Loop' indicator
shift @ThisLoop;
# get the Loop ID
$LoopID = shift @ThisLoop;
# get the maximum loop repeat value
$MaxLoopRepeat = shift @ThisLoop;
# get the next segment data
$ExpectedSegment = shift @ThisLoop;
# start at the top of the loop again
next;
} # end of while $ExpectedSegment->[$ID] eq 'Loop'
# the data file and the data template are not in synch
if ( $Segment->[$ID] ne $ExpectedSegment->[$ID] ) {
# is there a missing mandatory segment?
if ( $ExpectedSegment->[$Required] ) {
# yes
# set the status message
message "Parse error. Missing mandatory segment:
$ExpectedSegment->[$ID]";
# return failure
return $failure;
} # end of if $ExpectedSegment->[$Required]
# get the next segment data
$ExpectedSegment = shift @ThisLoop;
# start at the top of the loop again
next;
} # end of if $Segment->[$ID] ne $ExpectedSegment->[$ID]
# the data file and the data template are in synch
if ( $Segment->[$ID] eq $ExpectedSegment->[$ID] ) {
# increment the counter for this particular segment
$SegmentCount++;
# if there is a Max Use value and the count exceeds it...
if ( $ExpectedSegment->[$MaxUse] and $SegmentCount >
$ExpectedSegment->[$MaxUse] ) {
# look through the rest of the loop data to see
# if there are optional segments that are not in
# the data file. If so, then this is the next
# iteration of the current loop
foreach my $RemainingSegment ( @ThisLoop ) {
# is it a mandatory segment?
if ( $RemainingSegment->[$Required] ) {
# yes
# set the status message
message "Parse error. Max use violation or missing mandatory
segments.";
# return failure
return $failure;
} # end of if $RemainingSegment->[$Required]
} # end of foreach my $RemainingSegment ( @ThisLoop )
# got this far with no failure, therefore, start the next iteration
# get the stashed current loop structure
@ThisLoop = @{$CurrentLoopStack[$#CurrentLoopStack]};
# increment the count for this loop
$LoopCount++;
# remove the 'Loop' indicator
shift @ThisLoop;
# get the loop ID
$LoopID = shift @ThisLoop;
# get the Max Loop Repeat value
$MaxLoopRepeat = shift @ThisLoop;
# too many iterations of this loop?
if ( $MaxLoopRepeat and $LoopCount > $MaxLoopRepeat ) {
# yes
# set the status message
message "Parse error. Max loop repeat violation. Loop ID $LoopID.
Max Loop Repeat $MaxLoopRepeat.";
# return failure
return $failure;
} # end of if $LoopCount > $MaxLoopRepeat
# get the next segment data
$ExpectedSegment = shift @ThisLoop;
# clear the segment counter
$SegmentCount = 0;
# start at the top of the loop again
next;
} # end of if $ExpectedSegment->[$MaxUse] and $SegmentCount >
$ExpectedSegment->[$MaxUse]
# DO SOMETHING WITH THE CONTENTS OF THE INPUT SEGMENT
if ( $args{'sub'} and ref $args{'sub'} eq 'CODE' ) {
my $status = TheSub($LoopID, $Segment, $ExpectedSegment->[$SeqNo]);
print STDERR message, "\n" if $status eq $failure;
} # end of if $args{'sub'} and ref $args{'sub'} eq 'CODE'
# get the next segment from the data file
unless ( defined($Segment = GetNextSegment()) ) {
# no
# set the status message
message "no more data to parse.";
# return success
return $success;
} # end of if not defined $Segment
# does the actual segment match the expected segment?
if ( $Segment->[$ID] ne $ExpectedSegment->[$ID] ) {
# no
# get the next segment data
$ExpectedSegment = shift @ThisLoop;
# clear the segment counter
$SegmentCount = 0;
} # end of if $Segment->[$ID] ne $ExpectedSegment->[$ID]
# start at the top of the loop again
next;
} # end of if $Segment->[$ID] eq $ExpectedSegment->[$ID]
# if we get this far, something is wrong
message "Parse error";
last;
} # end of SEGMENT: while <FILE>
} # end of sub Parse
------------------------------
Date: 25 Oct 1999 03:14:47 -0500
From: abigail@delanet.com (Abigail)
Subject: Re: Request style comments (code included - longish)
Message-Id: <slrn8184au.fji.abigail@alexandra.delanet.com>
Larry Rosler (lr@hpl.hp.com) wrote on MMCCXLVI September MCMXCIII in
<URL:news:MPG.127d755f18dfd0ef98a118@nntp.hpl.hp.com>:
@@ In article <7uuvq4$g43$1@gellyfish.btinternet.com> on 24 Oct 1999
@@ 12:58:44 -0000, Jonathan Stowe <gellyfish@gellyfish.com> says...
@@
@@ ...
@@
@@ > > print LOG "\n\n############################################\n\n";
@@ > > print LOG "New testing session begun on $date, $iter iterations
@@ > > requested.\n\n";
@@ > > print LOG "Hostname is $host.\n";
@@ > > print LOG "Default receive buffer size is $rcvbufdef bytes.\n";
@@ > > print LOG "Maximum receive buffer size is $rcvbufmax bytes.\n";
@@ > > print LOG "Default transmit buffer size is $xmtbufdef bytes.\n";
@@ > > print LOG "Maximum transmit buffer size is $xmtbufmax bytes.\n";
@@ > > print LOG "Average RTT is $rtt milliseconds.\n\n";
@@ > > print LOG "Results as follows:\n\n";
@@ >
@@ > Personally as soon as I see more than two consecutive print()s I immediately
@@ > reach for the 'here doc'
@@
@@ Personally as soon as I see more than one consecutive print() I
@@ immediately reach for the 'comma' key.
@@
@@ print LOG "\n\n############################################\n\n",
@@ "New testing session begun on $date, $iter iterations
And I would use a here documents....
print LOG <<EOT;
############################################
New testing session begun on $date, $iter iterations requested.
Hostname is $host.
Default receive buffer size is $rcvbufdef bytes.
Maximum receive buffer size is $rcvbufmax bytes.
Default transmit buffer size is $xmtbufdef bytes.
Maximum transmit buffer size is $xmtbufmax bytes.
Average RTT is $rtt milliseconds.
Results as follows:
EOT
Save quite some typing of " and \n.
Abigail
--
sub camel (^#87=i@J&&&#]u'^^s]#'#={123{#}7890t[0.9]9@+*`"'***}A&&&}n2o}00}t324i;
h[{e **###{r{+P={**{e^^^#'#i@{r'^=^{l+{#}H***i[0.9]&@a5`"':&^;&^,*&^$43##@@####;
c}^^^&&&k}&&&}#=e*****[]}'r####'`=437*{#};::'1[0.9]2@43`"'*#==[[.{{],,,1278@#@);
print+((($llama=prototype'camel')=~y|+{#}$=^*&[0-9]i@:;`"',.| |d)&&$llama."\n");
-----------== Posted via Newsfeeds.Com, Uncensored Usenet News ==----------
http://www.newsfeeds.com The Largest Usenet Servers in the World!
------== Over 73,000 Newsgroups - Including Dedicated Binaries Servers ==-----
------------------------------
Date: 25 Oct 1999 09:29:40 +0100
From: Jonathan Stowe <gellyfish@gellyfish.com>
Subject: Re: Request style comments (code included - longish)
Message-Id: <381414f4_2@newsread3.dircon.co.uk>
Rick Delaney <rick.delaney@home.com> wrote:
> [posted & mailed]
>
> Jonathan Stowe wrote:
>>
>> On Sun, 24 Oct 1999 08:38:13 GMT Carrie Duffy wrote:
>> >
>> > Can anyone offer some tips to help make my code
>> > easier to parse (for humans, that is :P). Thanks!
> ...
>> > $rcvbufdef= `cat /proc/sys/net/core/rmem_default`;
>> > chomp ($rcvbufdef);
>> >
>>
>> Useless use of 'cat' and backticks : you could open these files directly
>> in Perl and read them straight in - probably setting $/ to undef to
>> slurp the entire contents.
>>
>> {
>> local $/;
>> opem(RMEMDEF,'/proc/sys/net/core/rmem_default' ) || die " ... - $!\n";
>> chomp($rcvbufdef = <RMEMDEF>);
> ^^^^^
> That's not chomping what it should be chomping.
>
Er yes, ahem ....
/J\
--
"If I was going to wear a wig I'd choose something a lot better than this"
- Barry Norman
------------------------------
Date: Tue, 26 Oct 1999 15:25:50 GMT
From: cpierce1@ford.com (Clinton Pierce)
Subject: Review request! Does this module seem useful/correct?
Message-Id: <3817c346.1808892179@news.ford.com>
At the bottom of this is Catch.pm, a module I've been using to catch the
STDOUT and STDERR of functions. Usually I do this because the functions
emit stuff that I'd really like to cook (or ignore) before sending it out
but I don't have control of the API to fix the function to return
something sane.
Originally I did this with open(f, "-|") kinds of nonsense, but that
didn't feel clean, and doesn't work under Win32.
Criticisms welcome, both for style and functionality.
=head1 NAME
Catch - catch output of function
=head1 SYNOPSIS
use Catch;
($output, $error, @retval)=catchit(&foofunc, @args);
($output, $error, $retval)=catchit(&foofunc, @args);
=head1 DESCRIPTION
The catchit() function runs a specified function, with the given arguments
and captures the STDOUT and STDERR emissions from that function.
This is useful when you've got to call a function which prints data, but
the data needs to be "cooked" before display or needs to be thrown away
altogether. This is especially useful for functions whose code you have
no control over, and would rather not copy the function or start all over.
The function is run in an eval {}, so that STDERR and STDOUT will be fixed
even if the function dies. The die() is re-performed after the file
handles are cleaned up.
=head1 RETURNS
=over 4
=item &foofunc
The function you want run and captured.
=item @args
The arguments to that function.
=item $output
The captured STDOUT of the function. The output isn't cooked in any way.
=item $error
The captured STDERR of the function.
=item @retval, $retval
The return values of the function.
=back
=head1 EXAMPLE
use Catch;
sub messy {
my(@args)=@_;
select(STDOUT);
print "Here's some standard output. Blah, blah: @args";
warn "Danger Will Robinson!";
return(1);
}
($output, $errors, $retval)=catchit(\&messy, "Print me!");
=head1 BUGS
=over 4
=item *
If the function called returns a list, and you use a scalar to receive
them, only the first value is put into the scalar. Presumably, since you
know what the API for this function is anyway, use the right type: an
array or a scalar.
=item *
Doesn't take kindly to functions that move/re-open STDOUT and STDERR or
that play with the __WARN__ handler.
=item *
Not really a bug, but calling programs in backticks (system, pipes, etc..)
and XS programs which output directly to stderr/stdout bypass this
mechanism completely. That's not what this is for.
=back
=head1 AUTHOR
Clinton Pierce (F<clintp@geeksalad.org>)
All rights reserved. This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
=cut
package Catch;
require 5.005;
use strict;
use Carp;
use vars qw(@EXPORT $VERSION @ISA $AUTOLOAD %UNK);
use Exporter;
@ISA=qw(Exporter);
@EXPORT=qw( catchit );
$VERSION=1.00;
%UNK=(
READ => \&read_warning,
READLINE => \&read_warning,
GETC => \&read_warning,
CLOSE => sub { 1;},
DESTROY => sub { 1;},
);
sub catchit {
my($coderef, @args)=@_;
open(SAVEOUT, ">&STDOUT") || warn "Cannot save STDOUT: $!\n";
open(SAVEERR, ">&STDERR") || warn "Cannot save STDERR: $!\n";
print SAVEOUT ""; # To silence the "used only once" warning
print SAVEERR ""; # for the filehandles.
my($out,$err)=("","");
my $cap_out=tie(*STDOUT, 'Catch', \$out);
my $cap_err=tie(*STDERR, 'Catch', \$err);
my @retval;
# warn() doesn't seem to print to STDERR through Perl.
# Catch that manually.
my($old_warn)=$SIG{__WARN__};
$SIG{__WARN__}= sub {
print STDERR "@_"
};
eval {
@retval=&$coderef(@args);
};
$SIG{__WARN__}=$old_warn;
undef $cap_out; # To silence "inner references" warnings
undef $cap_err; # as documented in "perltie"
untie(*STDOUT);
untie(*STDERR);
open(STDOUT, ">&SAVEOUT") || warn "Cannot restore STDOUT: $!\n";
open(STDERR, ">&SAVEERR") || warn "Cannot restore STDERR: $!\n";
if ($@) {
die "$@";
}
return($out, $err, @retval);
}
sub TIEHANDLE {
my($class,$vref)=@_;
my $self={
data=> $vref
};
bless($self, $class);
return($self);
}
sub WRITE {
my($self)=shift;
my($buf, $len, $offset)=@_;
${ $self->{data} }.=$buf;
return 1;
}
sub PRINT {
my($self)=shift;
${ $self->{data} }.=join('', @_);
return 1;
}
sub PRINTF {
my($self)=shift;
my $fmt=shift;
${ $self->{data}}.=sprintf($fmt, @_);
return 1;
}
sub AUTOLOAD {
my($self)=@_;
my $attr=$AUTOLOAD;
$AUTOLOAD=~s/.*:://;
if (exists $UNK{$AUTOLOAD}) {
&{ $UNK{$AUTOLOAD} };
}
}
sub read_warning {
carp "Cannot read from specified filehandle.";
}
1;
--
Clinton A. Pierce "If you rush a Miracle Man, you
clintp@geeksalad.org get rotten Miracles." -- Miracle Max,
http://www.geeksalad.org The Princess Bride
------------------------------
Date: 27 Oct 1999 17:48:29 GMT
From: mjtg@cus.cam.ac.uk (M.J.T. Guy)
Subject: Re: Review request! Does this module seem useful/correct?
Message-Id: <7v7dtd$j1i$1@pegasus.csx.cam.ac.uk>
Clinton Pierce <cpierce1@ford.com> wrote:
>
> print SAVEOUT ""; # To silence the "used only once" warning
> print SAVEERR ""; # for the filehandles.
Eh? I don't see this warning. And in any case the perlish way
to deal with it would be
use vars qw(*SAVEOUT *SAVEERR);
Mike Guy
------------------------------
Date: Tue, 26 Oct 1999 23:33:14 GMT
From: clintp@geeksalad.org (Clinton Pierce)
Subject: Re: Review request! Does this module seem useful/correct?
Message-Id: <3816387d.347839304@news.roalok1.mi.home.com>
On Tue, 26 Oct 1999 16:30:54 -0400, Ala Qumsieh <aqumsieh@matrox.com>
wrote:
>cpierce1@ford.com (Clinton Pierce) writes:
>
>> =head1 BUGS
>> If the function called returns a list, and you use a scalar to receive
>> them, only the first value is put into the scalar. Presumably, since you
>> know what the API for this function is anyway, use the right type: an
>> array or a scalar.
>
>So what happens if the called function uses wantarray() ?
It loses. :-) That is a valid criticism, I suppose. And I should
document it.
That's why this is under the "bugs" section. Without adding
additional parameters to the catchit() call, there's no way to
indicate that you'd like the target function called in an array or
scalar context. The purpose of this class is itself a hack to get
around someone else's broken API.
In the choice between simplicity and completeness, I chose simplicity.
--
"If you rush a Miracle Man, you get rotten miracles"
--Miracle Max, The Princess Bride
http://www.geeksalad.org
------------------------------
Date: Tue, 26 Oct 1999 16:30:54 -0400
From: Ala Qumsieh <aqumsieh@matrox.com>
Subject: Re: Review request! Does this module seem useful/correct?
Message-Id: <x3ywvs9985d.fsf@tigre.matrox.com>
cpierce1@ford.com (Clinton Pierce) writes:
> =head1 BUGS
>
> =over 4
>
> =item *
>
> If the function called returns a list, and you use a scalar to receive
> them, only the first value is put into the scalar. Presumably, since you
> know what the API for this function is anyway, use the right type: an
> array or a scalar.
So what happens if the called function uses wantarray() ?
--Ala
------------------------------
Date: Tue, 26 Oct 1999 22:12:40 -0700
From: tgy@chocobo.org (Neko)
Subject: Re: Review request! Does this module seem useful/correct?
Message-Id: <DHUWOPN7Dpk=vDz94T5wKqPh51Gh@4ax.com>
On Tue, 26 Oct 1999 15:25:50 GMT, cpierce1@ford.com (Clinton Pierce) wrote:
>At the bottom of this is Catch.pm, a module I've been using to catch the
>STDOUT and STDERR of functions. Usually I do this because the functions
>emit stuff that I'd really like to cook (or ignore) before sending it out
>but I don't have control of the API to fix the function to return
>something sane.
The name 'Catch' makes me think try/throw/catch/except/finally/etc. It
really sounds like you are trying to 'capture' output rather than 'catch' it
(think backticks), so maybe 'Capture' would be a better name, or maybe even
'IO::Capture' if destined for CPAN.
>Criticisms welcome, both for style and functionality.
>
>
>=head1 NAME
>
>Catch - catch output of function
>
>=head1 SYNOPSIS
>
> use Catch;
>
> ($output, $error, @retval)=catchit(&foofunc, @args);
> ($output, $error, $retval)=catchit(&foofunc, @args);
Have you considered using a '&' prototype? So instead of capturing STDOUT
and STDERR for a single function, you can do it for an entire code block.
This also gets around any wantarray() problems.
use IO::Capture;
($out, $err, @ret) = capture { foofunc @args }; # list context
($out, $err, @ret) = capture { scalar foofunc @args };
($out, $err, @ret) = capture {
foofunc @args; # void
my $scalar = foofunc @args; # scalar
my @array = foofunc @args; # list
return 42;
};
>
>package Catch;
>require 5.005;
>use strict;
>use Carp;
>use vars qw(@EXPORT $VERSION @ISA $AUTOLOAD %UNK);
>
>use Exporter;
>@ISA=qw(Exporter);
>
>@EXPORT=qw( catchit );
>$VERSION=1.00;
>
>%UNK=(
> READ => \&read_warning,
> READLINE => \&read_warning,
> GETC => \&read_warning,
> CLOSE => sub { 1;},
> DESTROY => sub { 1;},
>);
I dislike this hash and the associated AUTOLOAD. It seems unnecessary.
use vars qw[*READ *READLINE *GETC];
*READ = *READLINE = *GETC = \&read_warning;
sub CLOSE {}
sub DESTROY {}
>sub catchit {
> my($coderef, @args)=@_;
sub capture ($) { # if prototyped for code block
my $coderef = shift;
> open(SAVEOUT, ">&STDOUT") || warn "Cannot save STDOUT: $!\n";
> open(SAVEERR, ">&STDERR") || warn "Cannot save STDERR: $!\n";
I thought you could tie and untie STDOUT/STDERR without disturbing the
original filehandles. It seems to be implemented but not documented to work
this way. Would localizing the filehandles also work?
> print SAVEOUT ""; # To silence the "used only once" warning
> print SAVEERR ""; # for the filehandles.
close SAVEOUT; # Somewhere closer to the bottom of course.
> my($out,$err)=("","");
>
> my $cap_out=tie(*STDOUT, 'Catch', \$out);
> my $cap_err=tie(*STDERR, 'Catch', \$err);
> my @retval;
You never use $cap_out and $cap_err, except to create a bug to step around.
> # warn() doesn't seem to print to STDERR through Perl.
> # Catch that manually.
> my($old_warn)=$SIG{__WARN__};
>
> $SIG{__WARN__}= sub {
> print STDERR "@_"
> };
local() will save and restore the handler for you. I am also unsure why you
want spaces between your arguments.
local $SIG{__WARN__} = sub { print STDERR @_ };
> eval {
> @retval=&$coderef(@args);
@retval = $coderef->(); # if prototyped for code block
> };
> $SIG{__WARN__}=$old_warn;
>
> undef $cap_out; # To silence "inner references" warnings
> undef $cap_err; # as documented in "perltie"
See? Just omit $cap_out and $cap_err altogether.
> untie(*STDOUT);
> untie(*STDERR);
> open(STDOUT, ">&SAVEOUT") || warn "Cannot restore STDOUT: $!\n";
> open(STDERR, ">&SAVEERR") || warn "Cannot restore STDERR: $!\n";
> if ($@) {
> die "$@";
> }
> return($out, $err, @retval);
>}
[snip TIEHANDLE]
>sub WRITE {
> my($self)=shift;
>
> my($buf, $len, $offset)=@_;
my $str = substr $buf, $offset || 0, $len;
${ $self->{data} } .= $str;
return length $str;
> ${ $self->{data} }.=$buf;
> return 1;
>}
>sub PRINT {
> my($self)=shift;
local $^W;
${ $self->{data} } .= join($,, @_) . $\;
return 1;
> ${ $self->{data} }.=join('', @_);
> return 1;
>}
[snip PRINTF, AUTOLOAD, read_warning]
--
Neko | tgy@chocobo.org | Will hack Perl for a moogle stuffy! =^.^=
------------------------------
Date: Tue, 26 Oct 1999 16:31:46 -0700
From: David Cassell <cassell@mail.cor.epa.gov>
Subject: Re: robust telnet solution?
Message-Id: <381639E2.E41B4CAB@mail.cor.epa.gov>
rootdog wrote:
>
> Thank you for responding Mr. Phoenix. Would you have any specific
> recomendations as regards to modules or references?
You might be interested in the libnet bundle, which includes
Net::Telnet .
David
--
David Cassell, OAO cassell@mail.cor.epa.gov
Senior computing specialist
mathematical statistician
------------------------------
Date: Tue, 26 Oct 1999 14:25:32 -0700
From: Tom Phoenix <rootbeer@redcat.com>
Subject: Re: robust telnet solution?
Message-Id: <Pine.GSO.4.10.9910261424190.29843-100000@user2.teleport.com>
On Mon, 25 Oct 1999, rootdog wrote:
> Thank you for responding Mr. Phoenix. Would you have any specific
> recomendations as regards to modules or references?
Have you seen the modules list on CPAN?
http://www.cpan.org/
If some module isn't listed there, it should be. Cheers!
--
Tom Phoenix Perl Training and Hacking Esperanto
Randal Schwartz Case: http://www.rahul.net/jeffrey/ovs/
------------------------------
Date: Mon, 25 Oct 1999 21:00:44 -0700
From: "rootdog" <corlando@MUNGEpop.phnx.uswest.net>
Subject: Re: robust telnet solution?
Message-Id: <MG9R3.1346$x8.61821@news.uswest.net>
Thank you for responding Mr. Phoenix. Would you have any specific
recomendations as regards to modules or references?
------------------------------
Date: Mon, 25 Oct 1999 12:38:11 -0700
From: Tom Phoenix <rootbeer@redcat.com>
Subject: Re: robust telnet solution?
Message-Id: <Pine.GSO.4.10.9910251237010.29843-100000@user2.teleport.com>
On Fri, 22 Oct 1999, rootdog wrote:
> Is there a module and or method which ensures proper echoing of
> characters when writing an interactive client/server app in perl or
> any other language?
If you find a module which does _not_ do it properly (as defined in the
protocol spec) be sure to file a bug report with the author. Cheers!
--
Tom Phoenix Perl Training and Hacking Esperanto
Randal Schwartz Case: http://www.rahul.net/jeffrey/ovs/
------------------------------
Date: 16 Sep 99 21:33:47 GMT (Last modified)
From: Perl-Users-Request@ruby.oce.orst.edu (Perl-Users-Digest Admin)
Subject: Digest Administrivia (Last modified: 16 Sep 99)
Message-Id: <null>
Administrivia:
The Perl-Users Digest is a retransmission of the USENET newsgroup
comp.lang.perl.misc. For subscription or unsubscription requests, send
the single line:
subscribe perl-users
or:
unsubscribe perl-users
to almanac@ruby.oce.orst.edu.
| NOTE: The mail to news gateway, and thus the ability to submit articles
| through this service to the newsgroup, has been removed. I do not have
| time to individually vet each article to make sure that someone isn't
| abusing the service, and I no longer have any desire to waste my time
| dealing with the campus admins when some fool complains to them about an
| article that has come through the gateway instead of complaining
| to the source.
To submit articles to comp.lang.perl.announce, send your article to
clpa@perl.com.
To request back copies (available for a week or so), send your request
to almanac@ruby.oce.orst.edu with the command "send perl-users x.y",
where x is the volume number and y is the issue number.
For other requests pertaining to the digest, send mail to
perl-users-request@ruby.oce.orst.edu. Do not waste your time or mine
sending perl questions to the -request address, I don't have time to
answer them even if I did know the answer.
------------------------------
End of Perl-Users Digest V9 Issue 1197
**************************************
