$$xmlScalar_r = pack('U0C*', unpack('U0C*', SGMLencode_data($$xmlScalar_r)||(defined($$xmlScalar_r) ? $$xmlScalar_r : '') ));

$string = ...
$x = pack('U0C*', unpack('U0C*', $string));
[download]

$x = $string      #or without even $string, just $x = ...
[download]

When I tried to read nextline, the pointer in the while loop reads two lines at a time. Is there another creative way to deal with the file's next line?

use strict;
use warnings;
my %store; my $nextline; my $cnt=1;
my $filename = "$ARGV[0]";
open(my $fh, '<:encoding(UTF-8)', $filename) or die "Could not open fi
+le '$filename' $!";
     
while (my $row = <$fh>) {
    chomp $row;
    my @tmp = split /\s+/, $row;
    $nextline = <$fh>; chomp $nextline;
    my @nexttmp = split /\s+/, $nextline;
print "$row\t$cnt\n";
    if ($tmp[0] ne $nexttmp[0]) { 
        $cnt++; 
    }
print "$nextline\t$cnt\n";

}
close $filename;
[download]

Hi monks! Today I started studying Dancer with this tutorial and maybe I'm getting ahead but I wonder is there a way to apply default html filter to all variables?

So far I've only seen an example with explicit syntax like:

However, it seems to me that this approach may lead to the fact that developer may forget to apply the filter and xss will occurs.

Searching for this topic led me to node and to Template::AutoFilter but it was in early 2011.
Should i use this approach today or there are modern ways to achieve this? And can I use this with dancer?

I recently built perl 5.32.1 with -DDEBUGGING & DateTime 1.54 from source (Ports, FreeBSD 13-STABLE). Now use of DateTime results in "failed to extend arg stack" (a solution seems not likely any time soon, tagged as "low serverity) ...

# perl -MDateTime -e0
panic: XSUB Package::Stash::XS::list_all_symbols (XS.c) failed to exte
+nd arg stack: base=801cff418, sp=801cff480, hwm=801cff440
Compilation failed in require at /usr/local/lib/perl5/site_perl/mach/5
+.32/DateTime/Duration.pm line 12.
BEGIN failed--compilation aborted at /usr/local/lib/perl5/site_perl/ma
+ch/5.32/DateTime/Duration.pm line 12.
Compilation failed in require at /usr/local/lib/perl5/site_perl/mach/5
+.32/DateTime.pm line 14.
BEGIN failed--compilation aborted at /usr/local/lib/perl5/site_perl/ma
+ch/5.32/DateTime.pm line 14.
Compilation failed in require.
BEGIN failed--compilation aborted.
[download]

What good is -DDEBUGGING now if it XS modules cannot run.

Is there a way to have perl built with DEBUGGING and XS modules not fail?

Dear Monks,

I have spent quite some time in trying to do a seemingly simple task with Inline::C, that of passing a reference to a function and the function modifying it so that caller gets results back. I don't want to use the return() mechanism, so my function looks like int func(SV *inp, SV *out); inp is a readonly ref and out is the ref I would like to write to.

I have 3 cases I would like to deal with:

1. out is an arrayref, e.g. my @inp; my @out; func(\@inp, \@out); In this case I want to remove all elements of @out if any and then make it a 2D array of 5cols and 3rows, containing the number 42.

2. out is a scalar, e.g. my @inp; my $out; func(\@inp, $out); In this case I want to make $out an arrayref and proceed to fill it as above, so that caller can dereference as my @out = @$out.

3. out is a scalarref, e.g. my @inp; my $out; func(\@inp, \$out); In this case I want to find if its dereference, e.g. $out is a ref to any array or hash, or just a plain scalar. If it's a plain scalar I would like to make it an arrayref and proceed as above, so that caller can dereference as my @out = @$out.

Can anyone help me to fill any of the blanks in this advent calendar of perlguts?

Here is a test script testing each case.

use strict;
use warnings;

use Test::More;

use Inline C => Config =>
    BUILD_NOISY => 1,
    clean_after_build => 0,
    warnings => 10,
;
use Inline C => <<'EOC';
#include <stdio.h>

// checks if array is indeed an arrayref and sets array_sz to its size
+ and
// returns 1 else returns 0 (not an array)
int is_array_ref(
    SV *array,
    size_t *array_sz
){
    if( ! SvROK(array) ){ fprintf(stderr, "is_array_ref() : warning, i
+nput '%p' is not a reference.\n", array); return 0; }
    if( SvTYPE(SvRV(array)) != SVt_PVAV ){ fprintf(stderr, "is_array_r
+ef() : warning, input ref '%p' is not an ARRAY reference.\n", array);
+ return 0; }
    // it's an array, cast it to AV to get its len via av_len();
    // yes, av_len needs to be bumped up, it's $#array
    int asz = 1+av_len((AV *)SvRV(array));
    if( asz < 0 ){ fprintf(stderr, "is_array_ref() : error, input arra
+y ref '%p' has negative size!\n", array); return 0; }
    *array_sz = (size_t )asz;
    return 1; // success, it is an array and size returned by ref, abo
+ve
}

int func(
    SV *inp,
    SV *out
){
    AV *av, *av2;
    size_t i, j, asz;
    if( is_array_ref(out, &asz) ){
        printf("Case1: @out\n");
        // we have an \@R, e.g. func(\@R)
         av = (AV *)SvRV(out);
        // but first clear any contents
        if( asz > 0 ) av_clear(av);
    } else if( SvROK(out) ){
        printf("Case3: \\$out\n");
        // we have a scalar ref, e.g. func(\$x)
        av = newAV();
        sv_setsv(SvRV(out), (SV *)av);
    } else {
        printf("Case2: $out\n");
        // we have a scalar e.g func($x);
        av = newAV();
        sv_setsv(out, (SV *)av);
    }
        // and fill it in
    for(i=0;i<5;i++){
        av2 = newAV();
        av_extend(av2, 3);
        av_push(av, (SV *)av2);
        for(j=0;j<3;j++){
            av_store(av2, j, newSViv(42));
        }
    }
    return 0; // success
}
EOC

my @inp = (1..5);
my @out;
my $T = 'Case1';
is(func(\@inp, \@out),0, "$T: called success.");
is(scalar(@out), 5, "$T: rows are 5");
for(my $i=0;$i<5;$i++){
    ok(ref($out[$i])eq'ARRAY', "$T : item $i is ARRAYref.");
    is(scalar($out[$i]), 3, "$T : it has 3 elements.");
        for(my $j=0;$j<3;$j++){
          is($out[$i]->[$j], 42, "$T : it's value is 42.");
        }
}

$T = 'Case2';
my $out;
is(func(\@inp, $out),0, "$T: called success.");
is(ref($out)eq'ARRAY', "$T: it is now an ARRAYref.");
@out = @$out;
is(scalar(@out), 5, "$T: rows are 5");
for(my $i=0;$i<5;$i++){
    ok(ref($out[$i])eq'ARRAY', "$T : item $i is ARRAYref.");
    is(scalar($out[$i]), 3, "$T : it has 3 elements.");
        for(my $j=0;$j<3;$j++){
          is($out[$i]->[$j], 42, "$T : it's value is 42.");
        }
}

$T = 'Case3';
$out = undef;
is(func(\@inp, \$out),0, "$T: called success.");
is(ref($out)eq'ARRAY', "$T: it is now an ARRAYref.");
@out = @$out;
is(scalar(@out), 5, "$T: rows are 5");
for(my $i=0;$i<5;$i++){
    ok(ref($out[$i])eq'ARRAY', "$T : item $i is ARRAYref.");
    is(scalar($out[$i]), 3, "$T : it has 3 elements.");
        for(my $j=0;$j<3;$j++){
          is($out[$i]->[$j], 42, "$T : it's value is 42.");
        }
}
done_testing();
[download]

thanks in advance, bw, bliako

Once in awhile Perl still surprises me.

This code is obviously broken:

my ($left, $right) = qw(abc def);
print "$left_$right\n";
[download]

The problem is that interpolation causes Perl to want to print a variable $left_ and $right, but we declared $left and $right. There are several ways to fix this, two of which are:

print "$left\_$right\n";
print "${left}$right\n";
[download]

...and of course you could just use the concatenation operator, but then I wouldn't have anything to puzzle over.

But observe the following:

my $string = "abcd";
if ($string =~ m/(ab)(cd)/) {
    print "$1_$2\n";
}
[download]

The output is ab_cd. So in this case Perl automatically treated that interpolation as "${1}_$2\n" without me telling it to do so. I've looked over The Gory details of parsing quoted constructs and haven't found an explanation. I assume that in the case of numbered regex variables, Perl decides that if the variable starts with a numeric digit, the identifier must end when there are no more numeric digits. Is this behavior reliable? Is it documented? Is it likely to ever change?

I'm asking because I found it in a code review and was sure it was broken until we talked it over and tested to verify the behavior was to parse "$1_$2\n" as $1 . '_' . $2 . "\n" even though we would prefer to disambiguate using \ or ${n}.

Update: I do see in perldata: Identifier-parsing:

Meanwhile, special identifiers don't follow the above rules; For the most part, all of the identifiers in this category have a special meaning given by Perl. Because they have special parsing rules, these generally can't be fully-qualified. They come in six forms (but don't use forms 5 and 6):

1. A sigil, followed solely by digits matching \p{POSIX_Digit}, like $0, $1, or $10000.

I don't know that this is worded quite right, because $1_ could be construed as NOT being an identifier consisting solely of digits. But it's the closest thing I can find to an explanation. But I'll take that as answering my own question: Yes, it's intentional and documented behavior.

sub TextFile 
{
    return 0 if (! -f $_[0]);
    return 0 if (! -r $_[0]);
    
    open FH, "<" . $_[0];
    my $block = " " x 4096;
    my $bytesread = sysread FH, $block, 4096;
    close FH;
    
    if (! defined $bytesread)
    {
        print "*** ERROR: TextFile: $_[0]: $!\n";
        return 0;
    }

    return $block =~ /^[\r\n\t -~]*$/s;
}
[download]

 
$block =~ /^[\r\n\t -~]*$/s
[download]

Dear Monks, I apologize I am completely clueless with Perl and as a favor have opted to help fix an old simulation model. The developer preceding me decided to use Perl to parse some data files, and for some reason it is no longer compiling and throwing errors. I am in the process of teaching myself Perl but any advice would be greatly appreciated. The errors being thrown: Experimental push on scalar is now forbidden at ../../plot_TTTDIA.pl line 44, near "@header)" Experimental push on scalar is now forbidden at ../../plot_TTTDIA.pl line 69, near "@twenty_SFs)" Execution of ../../plot_TTTDIA.pl aborted due to compilation errors.

#!/usr/bin/perl
use CGI::Carp qw(fatalsToBrowser);
use strict;
use warnings;
use feature 'say';
use List::Util 'max';

## If the @left curve passes through the @right curve,
## replace the values that pass with 'nan'.
sub trim_curves {
    my @left = @{shift @_}; # array of references
    my @right = @{shift @_};
    my $rows = shift @_; # integer
    my $y = $rows - 1;

    # Start reading from the tail of the data first.
    for (my $i = $y; $i >= 1; $i--) { # $i = 0 is the header
        if (${$left[$i]} > ${$right[$y]}) {
            ${$left[$i]} = 'nan';
            $y--;
        } else {
            # If @left is no longer greater, stop.
            last;
        }
    }
    return;
}

## Grab useful information from the $infile and put it
## into a column-oriented, tab-separated format.
sub parse_file {
    my $infile = shift @_;
    my $outfile = shift @_;

    open (my $in,  '<', $infile)  || die "Can't open $infile: $!";
    open (my $out, '>', $outfile) || die "Can't open $outfile: $!";

    # Build TTTPLOT data
    my @TTTPLOT; # 2D array
    my @header = ('Temperature', 'StartFerrite', 'StartPeralite', 'Sta
+rtBainite', 'MaxSF');
    for (my $i = 1; $i <= 20; $i++) {
       push @header, "SF($i)";
    }
    push /@TTTPLOT, /@header;

    # Current row index of @TTTPLOT
    my $index = 1;  # Index of 0 is the header above

    # Read the file's header data
    my $grade      = <$in>;
    my $chemcomp   = <$in>;
    my $grain      = <$in>;
    my $asymptotes = <$in>;

    # Read the file's per-temperature data
    while(<$in>) {
        # Split on multiple spaces using regex captured matches
        my @temp_and_starts = $_                              =~ /[^\s
+]+/g;
        my @last_AT_fracs   = <$in>                           =~ /[^\s
+]+/g;
        my @twenty_SFs      = (<$in> . <$in> . <$in> . <$in>) =~ /[^\s
+]+/g;
        my $max_SF          = max @twenty_SFs;

        # Build the @TTTPLOT row
        $TTTPLOT[$index]->[0] = $temp_and_starts[0];
        $TTTPLOT[$index]->[1] = $temp_and_starts[1];
        $TTTPLOT[$index]->[2] = $temp_and_starts[2];
        $TTTPLOT[$index]->[3] = $temp_and_starts[3];
        $TTTPLOT[$index]->[4] = $max_SF;
        push $TTTPLOT[$index], @twenty_SFs;
        $index++;
    }

    # Trim the overlapping tails off each combination of curves
    my @Fs = map \$_->[1], @TTTPLOT; # create an array of references
    my @Ps = map \$_->[2], @TTTPLOT;
    my @Bs = map \$_->[3], @TTTPLOT;
    trim_curves(\@Fs, \@Ps, $index); # check for ferrite greater than 
+pearlite
    trim_curves(\@Fs, \@Bs, $index); # check for ferrite greater than 
+bainite
    trim_curves(\@Ps, \@Bs, $index); # check for pearlite greater than
+ bainite

    # Output each row to the output file
    foreach my $row (@TTTPLOT) {
        say $out (join "\t", @{$row}); # tab-separated
    }

    close $in;
    close $out;
    return;
}

parse_file("./TTTPLOT.DAT", "./TTTPLOT_PARSED.DAT");
[download]

This parsed file is never being generated obviously which is why none of the data is being graphed.