A program in both Perl 5 and Perl 6

Here is the Perl 5 version of a program used to parse and reformat a plain-text file which originated in a reported downloaded from an old mainframe computer system.

$ cat medhist.pl
#!/usr/bin/perl
# medhist.pl
# Equivalent to mpc.pl, version 0.41 as of 8/21/01
# Must type in name of source file.  As written, assumes source file is in
# same directory as script.
# Automatically picks up client 7-digit "C" number
# Output file is named "(7-digit C no.)C.txt" and appears in same directory
# as script.
# No column headers -- just data.
$VERSION = 0.44;
use strict;
use warnings;
use Carp;

my ($cno, $strtdt, $stpdt, $type, $med, $dose, $freq);

##### BEGIN format definition #####
format MPCNYPHREPORT =
@<<<<<< @<<<<<<<<< @<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$cno,   $strtdt,   $stpdt,    $type,                              $med,                          $dose,               $freq
.
##### END format definition #####

my ($source, $outputdir, $tmpoutput, $oldfh);
croak "Need source file name as command-line argument"
    unless (@ARGV >= 1);
$source = shift(@ARGV);
croak "Cannot locate source file '$source'"
    unless (-f $source);
if (@ARGV) {
    $outputdir = shift(@ARGV);
    croak "Cannot locate output directory" unless (-d $outputdir);
}
else {
    $outputdir = '.';
}

$tmpoutput = "$outputdir/output.txt";
open(my $IN, '<', $source) || die "cannot open $source for reading: $!";
open(MPCNYPHREPORT, '>', $tmpoutput) || die "cannot create $tmpoutput: $!";
$oldfh = select MPCNYPHREPORT;
$= = 56;
select $oldfh;

my @out1 = ();
while (<$IN>) {
    s/^\*+$/----------/;
    $cno = $1 if m?\bCASE\s#\s:\s(\d\d\d\d\d\d\d)\s?;
    if (/\bFREQ:|^DOCTOR:|^-+$/) {
        push (@out1, $_);
    }
}

my ($in, @scrips, $md, $order);
foreach $_ (@out1) {
    if (/(.*)^-+$/) {
       $in .= $1;
    }
    else {
       $in .= $_;
    }
}

$in =~ s/(.*)\n(DOCTOR.*)/$1 $2/g;
@scrips = split /\n/, $in;

foreach (@scrips) {
    &warn_match_error($_) unless
        $_ =~ m/^
        (.+\b[.,\/?;:%*&\(\)\[\]]?)             # medication
        \s+FREQ:\s+(.+)\b                        # frequency
        \s+ORDER\s+\#\s+(\d+)                    # order number
        \s+STARTED\s{3}(\d{2}\/\d{2}\/\d{4})    # start date
        \s+DOCTOR:\s+(.+)                        # doctor
        \s+DOSE:\s+(.+)                          # dose
        \s+TYPE\s+(\w+)                         # type
        \s+STOPPED\s{3}(\d{2}\/\d{2}\/\d{4})    # stop date
        /x;
    $med = $1;  $freq = $2;  $order = $3;  $strtdt = $4;
    $md = $5;   $dose = $6;  $type = $7;   $stpdt = $8;
    write (MPCNYPHREPORT);
}

close ($IN) || die "can't close $source:$!";
close (MPCNYPHREPORT) || die "can't close $tmpoutput:$!";
my $newname = "$outputdir/$cno" . "C.txt";
rename ($tmpoutput, $newname) || die "Can't rename $tmpoutput to $newname: $!";
print "See results in this file:  $newname\n";

sub warn_match_error {
    my ($message) = @_;
    warn "ERROR: failed to match a record, data was\n"     . $message . "\n";
}

Here is the same program recently rewritten in Perl 6:

$ cat medhist.pl6 
#!/usr/bin/env perl6

my $source = "/home/jkeenan/learn/perl/medhist/rawdata.txt";
my $cno = '';
my @out1 = ();
for $source.IO.lines <-> $m is rw {
    next if $m ~~ m/^\w+$/;
    $m ~~ s/^\*+$/----------/;
    if $m ~~ m/CASE\s\#\s\:\s(\d**7)/ {
        unless $cno.chars {
            $cno = $0.Str;
        }
    }
    if $m ~~ m/FREQ\:|^DOCTOR\:|^\-+$/ {
#    if ($m ~~ m/FREQ\:|^DOCTOR\:/) {
        @out1.push($m);
    }
}

my $status = 0;
while (! $status) {
    if @out1[*-1] ~~ m/^\-+$/ {
        my $l = @out1.pop;
        $status = 0;
    }
    else {
        $status = 1;
    }
}

die "Intermediate array is faulty" unless $status;
#warn "Intermediate array is status: $status";

my $in = '';
loop (my $i = 0; $i < @out1.elems - 1; $i++) {
    if ($i % 3) {
        $in ~= @out1[$i] ~ "\n";
    }
}
$in ~= @out1[@out1.elems - 1];
$in ~~ s:g/\nDOCTOR/ DOCTOR/;

my $outstr = '';
for ($in.split("\n")) -> $j {
    my %this_scrip;
    if $j ~~ m/
        ^(.*?)
        \s+FREQ\:\s+
        (.*?)
        \s+ORDER\s+\#\s+
        (\d+)
        \s+STARTED\s+
        (\d**2\/\d**2\/\d**4)
        \sDOCTOR\:\s+
        (.*?)
        \s+DOSE\:\s+
        (.*?)
        \s+TYPE\s+
        (.*?)
        \s+STOPPED\s+
        (\d**2\/\d**2\/\d**4)
    / {
        %this_scrip< medication frequency order_number start_date doctor dose type stop_date > =
            ($0, $1, $2, $3, $4, $5, $6, $7).map: { $_.Str };
    }
    else {
        warn "$j: Failed to match";
    }
    $outstr ~= sprintf("%-8s%-11s%-11s%-36s%-31s%-21s%-s\n",
        $cno,
        %this_scrip.<start_date stop_date type medication dose frequency>,
    );
}
say $outstr.chomp;

Here is the Perl 6 program annotated to show differences in approach between the two languages:

$ cat annotated_medhist.pl6 
#!/usr/bin/env perl6

my $source = "/home/jkeenan/learn/perl/medhist/rawdata.txt";
my $cno = '';
my @out1 = ();

#`{{
1. Perl5 uses a filehandle to iterate over lines read from a file: while (my $l = <$IN>) {}.
   Perl6 uses: for $filename.IO.lines -> $l        {} (where we treat the line as read-only)
           or: for $filename.IO.lines <-> $m is rw {} (where we treat the line as modifiable)
2. Note distinction between '->' and '<->'.
}}

for $source.IO.lines <-> $m is rw {
#`{{
3. Perl5 regex binding: =~
   Perl6              : ~~
}}
    next if $m ~~ m/^\w+$/;
    $m ~~ s/^\*+$/----------/;
#`{{
4. Perl5 regex quantifier (single): {7}
   Perl6                          : **7
}}
    if $m ~~ m/CASE\s\#\s\:\s(\d**7)/ {
#`{{
5. Perl5 would say:  unless (length($cno)) {}
   Perl6          :  unless $cno.chars {}
6. Perl5 captures strings and places them in variables starting with $1
   Perl6 creates Capture objects starting with $0; use $0.Str to stringify them
}}
        unless $cno.chars {
            $cno = $0.Str;
        }
    }
#`{{
7. Perl6: inside patterns you have to escape punctuation characters like ':' and '-'

    Why doesn't this DTRT?
    if ($m ~~ m/FREQ\:|^DOCTOR\:/) {
}}
    if $m ~~ m/FREQ\:|^DOCTOR\:|^\-+$/ {
#`{{
8. Perl5                :   push(@out1, $m);
   Perl6 (method syntax):   @out1.push($m);
}}
        @out1.push($m);
    }
}

my $status = 0;
while (! $status) {
#`{{
8. Perl5:   if (@out1[-1] =~ m/^-+$/) {}
   Perl6:   if @out1[*-1] ~~ m/^\-+$/ {}
}}
    if @out1[*-1] ~~ m/^\-+$/ {
        my $l = @out1.pop;
        $status = 0;
    }
    else {
        $status = 1;
    }
}

die "Intermediate array is faulty" unless $status;
#warn "Intermediate array is status: $status";

my $in = '';
#`{{
9. Perl5 C-style 'for' loop:    for (my $i = 0; $i < $#out1; $i++) {}
   Perl6 loop:                  loop (my $i = 0; $i < @out1.elems - 1; $i++) {}
}}
loop (my $i = 0; $i < @out1.elems - 1; $i++) {
#`{{
10. Perl5 string concatenation: .   .=
    Perl6                     : ~   ~=
}}
    if ($i % 3) {
        $in ~= @out1[$i] ~ "\n";
    }
}
$in ~= @out1[@out1.elems - 1];
#`{{
11. Perl5 global substitution modifier:    s/\nDOCTOR/ DOCTOR/g
    Perl6 global substitution adverb:      s:g/\nDOCTOR/ DOCTOR/
}}
$in ~~ s:g/\nDOCTOR/ DOCTOR/;

my $outstr = '';
for ($in.split("\n")) -> $j {
    my %this_scrip;
    if $j ~~ m/
        ^(.*?)
        \s+FREQ\:\s+
        (.*?)
        \s+ORDER\s+\#\s+
        (\d+)
        \s+STARTED\s+
        (\d**2\/\d**2\/\d**4)
        \sDOCTOR\:\s+
        (.*?)
        \s+DOSE\:\s+
        (.*?)
        \s+TYPE\s+
        (.*?)
        \s+STOPPED\s+
        (\d**2\/\d**2\/\d**4)
    / {
#`{{
12. Perl5 hash slice assignment:    @hash{ qw( medication frequency ) } = ($1, $2);
    Perl6                      :    %hash< medication frequency >       = ($0, $1);
13. Perl5 map:  @left = map { stringify($_) } @right;
    Perl6 map:  @left = @right.map: { $_.Str };
}}
        %this_scrip< medication frequency order_number start_date doctor dose type stop_date > =
            ($0, $1, $2, $3, $4, $5, $6, $7).map: { $_.Str };
    }
    else {
        warn "$j: Failed to match";
    }
    $outstr ~= sprintf("%-8s%-11s%-11s%-36s%-31s%-21s%-s\n",
        $cno,
#`{{
14. Perl5 hash slice:    @hash{ qw( medication frequency ) };
    Perl6           :    %hash.< medication frequency >;
}}
        %this_scrip.<start_date stop_date type medication dose frequency>,
    );
}
#`{{
15. Perl5 chomp: modifies target (by removing $/); returns total number of characters removed
    Perl6 chomp: leaves target intact; returns new string which is target less logical newline
}}
say $outstr.chomp;