scratchpad
choroba
<h2>Rng</h2>
(for [Discipulus])
<c>
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
{ package My;
sub new {
return bless{ rng => $_[1] // sub { 1 + int rand($_[0]) } }, $_[0]
}
sub rand { $_[0]->{rng}($_[1]) }
}
my $o = 'My'->new();
say o => $o->rand(6) for 1 .. 7;
my @values = 1 .. 6;
my $i;
my $t = 'My'->new(sub { $values[$i++ % @values] });
say t => $t->rand(6) for 1 .. 7;
</c>
<hr>
<h2>Order of Evaluation</h2>
(for [haukex])
<c>#!/usr/bin/perl
use strict;
use warnings;
use feature qw{ say };
{ package MyScalar;
use Tie::Scalar;
use parent -norequire => 'Tie::StdScalar' ;
sub FETCH { warn 'f'; $_[0]->SUPER::FETCH(@_[1..$#_]) }
sub STORE { warn "s$_[1]"; $_[0]->SUPER::STORE(@_[1..$#_]) }
}
tie my $s, 'MyScalar', 5;
say $s, $s = 4;
say "" . $s, $s = 3;
</c>
<hr>
<a name="regex-benchmark"></a>
<h2>Benchmarking qr// versus /o</h2>
<c>#! /usr/bin/perl
use warnings;
use strict;
use Benchmark qw{ cmpthese };
use Test::More;
print $], "\n";
open my $W, '<', '/var/lib/dict/words' or die;
my @words = <$W>;
close $W;
my $s = '(.)(.)(.)\3\2\1';
my $re = qr/$s/;
my $tab = {
re => eval qq<sub { grep /$s/, \@words }>,
qr => sub { grep /$re/, @words },
qro => sub { grep /$re/o, @words },
s => sub { grep /$s/, @words },
so => sub { grep /$s/o, @words },
};
my $n = $tab->{re}->();
is $tab->{$_}->(), $n, $_ for qw( qr qro s so );
done_testing();
cmpthese(-5, $tab);
</c><P>
<hr>
<h2>decode</h2>
<c>#!/usr/bin/perl
use warnings;
use strict;
sub decode {
require Encode;
Encode::decode('UTF-8', shift);
}
print decode('abc');
</c><P>
<hr>
<h2>lvalue methods</h2>
<c>
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
{
package My;
sub new { bless {}, shift }
sub attr () :lvalue { shift->{attr} }
}
my $o = 'My'->new;
$o->attr = 12;
say $o->attr;
</c>
<hr>
<h2>For Lady_Aleena</h2>
<c>
#!/usr/bin/perl
use warnings;
use strict;
my @options;
if ('backport' eq $ARGV[0]) {
shift;
my $release = qx{ lsb_release -sc };
push @options, -t => "$release-backports";
}
system 'sudo', 'apt-get', @options, 'install', @ARGV;
</c>
<hr>
<a name="salad"></a><h2>Angry Fruit Salad</h2>
<c>
#! /usr/bin/perl
use warnings ;
use strict ;
sub setup {
my $self = shift ;
$self->start_mode('mode1') ;
$self->mode_param('rm') ;
$self->run_modes(
'mode1' => 'do_stuff' ,
'mode2' => 'do_more_stuff' ,
'mode3' => 'do_something_else'
) ;
}
</c>
<hr>
<h2>For [ww]: Duplicate output</h2>
When using your inserts, I'm still not getting the output lines duplicated.
<c>
#! /usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
use Syntax::Construct qw{ // };
use DBI;
my $db = 'DBI'->connect('dbi:SQLite:dbname=:memory:', q(), q(), {
RaiseError => 1,
});
$db->do(<< '__SQL__');
CREATE TABLE items (
ID INTEGER PRIMARY KEY AUTOINCREMENT,
link_id INTEGER,
item VARCHAR NOT NULL,
style VARCHAR)
__SQL__
$db->do(<< '__SQL__');
CREATE TABLE times (
ID INTEGER PRIMARY KEY AUTOINCREMENT,
link_id INTEGER,
time1 VARCHAR,
time2 VARCHAR,
location VARCHAR,
who VARCHAR,
note VARCHAR,
extra VARCHAR)
__SQL__
my $insert = $db->prepare(<< '__SQL__');
INSERT INTO items(link_id, item, style) VALUES(?, ?, ?)
__SQL__
$insert->execute(@$_) for
[ 1, 'Large RV Permit Holders must arrive', "H" ],
[ 2, 'Early Entry Permit Holders can arrive', "H"],
[ 3, 'Registration Gate ', "H"],
[ 4, 'Shuttle Bus Operates', "H"],
[ 42, 'The Science of Byurakan: The Golden Era of Soviet Astronomy', "A"],
[ 43, 'Astro Activities for Children', "K"],
[ 44, 'Stellafane New Horizons Project', "Y"],
[ 45, 'Scope Making For Teens', "Y"],
[ 46, 'Scope Making Demo', "T"];
$insert = $db->prepare(<< '__SQL__');
INSERT INTO times (link_id, time1, time2, location, who, note, extra)
VALUES(?, ?, ?, ?, ?, ?, ?)
__SQL__
$insert->execute(@$_) for
[ 1 , "2016-08-04 12:00", "2016-08-04 16:00", "Entry Gate", "", "Please don't arrive before Noon!", "" ],
[ 2 , "2016-08-04 15:00", "2016-08-04 22:00", "Entry Gate", "", "Please don't arrive before 3:00!", "" ],
[ 3 , "2016-08-05 09:00", "2016-08-05 22:00", "Entry Gate", "", "Hours", "" ],
[ 3 , "2016-08-06 07:00", "2016-08-06 19:00", "Entry Gate", "", "Hours", "" ],
[ 4 , "2016-08-05 10:00", "2016-08-05 18:00", "Bus Stops", "", "Bus Stops: Pine Island, Food Tent, Pink Clubhouse", "" ],
[ 4 , "2016-08-06 09:00", "2016-08-06 17:00", "Bus Stops", "", "Bus Stops: Pine Island, Food Tent, Pink Clubhouse", "" ],
[ 44 , "2016-08-05 13:00", "2016-08-05 17:00", "Bunkhouse", "Paul Fucile and James Lee", "(Teens 12-16)<i class='YellowHighlight'>(Requires Signup)</i>", "Modeling technology from the New Horizons" ],
[ 45 , "2016-08-06 11:00", "2016-08-06 12:30", "Bunkhouse", "\"Stargazer\" Steve Dodson", "Ages 12-16", "" ],
[ 46 , "2016-08-05 10:00", "2016-08-05 16:00", "Tent north of Pavilion", "Ray Morits", "ATM Demo Hours", "" ],
[ 46 , "2016-08-06 10:00", "2016-08-06 16:00", "Tent north of Pavilion", "Ray Morits", "ATM Demo Hours", "" ],
[ 46 , "2016-08-05 10:00:01", "2016-08-05 10:30", "Tent north of Pavilion", "Ray Morits", "Intro & Rough Grinding", "Intro & Rough Grinding" ],
[ 46 , "2016-08-06 10:00:01", "2016-08-06 10:30", "Tent north of Pavilion", "Ray Morits", "Intro & Rough Grinding", "Intro & Rough Grinding" ],
[ 46 , "2016-08-05 10:30", "2016-08-05 11:00", "Tent north of Pavilion", "Rick Hunter", "Fine Grinding", "Fine Grinding" ],
[ 46 , "2016-08-06 10:30", "2016-08-06 11:00", "Tent north of Pavilion", "Rick Hunter", "Fine Grinding", "Fine Grinding" ],
[ 46 , "2016-08-05 11:00", "2016-08-05 13:30", "Tent north of Pavilion", "Junie Esslinger", "Making Dental Stone Tools", "Making Dental Stone Tools" ],
[ 46 , "2016-08-06 11:00", "2016-08-06 11:30", "Tent north of Pavilion", "Junie Esslinger", "Making Dental Stone Tools", "Making Dental Stone Tools" ],
[ 46 , "2016-08-05 11:30", "2016-08-05 12:00", "Tent north of Pavilion", "Phil Rounseville","Making Pitch Laps", "Making Pitch Laps" ],
[ 46 , "2016-08-06 11:30", "2016-08-06 12:00", "Tent north of Pavilion", "Phil Rounseville","Making Pitch Laps", "Making Pitch Laps" ],
[ 46 , "2016-08-05 13:00", "2016-08-05 14:00", "Tent north of Pavilion", "Dave Groski", "Polishing & Figuring", "Polishing & Figuring" ],
[ 46 , "2016-08-06 13:00", "2016-08-06 14:00", "Tent north of Pavilion", "Dave Groski", "Polishing & Figuring", "Polishing & Figuring" ],
[ 46 , "2016-08-05 14:00", "2016-08-05 16:00", "Mirror Lab Room in Pavilion", "Dave Kelly", "Testing (Bring your own mirror)", "Testing (Bring your own mirror)" ],
[ 46 , "2016-08-06 14:00", "2016-08-06 16:00", "Tent north of Pavilion", "Ken Slater", "Dobsonian Basics", "Dobsonian Basics" ];
my $select = $db->prepare(<< '__SQL__');
SELECT item, time1, time2, location, who, note, extra
FROM items
INNER JOIN times
ON items.link_id = times.link_id
WHERE times.time1 LIKE "2016-08-06 %"
ORDER BY times.time1
__SQL__
$select->execute;
while (my @row = $select->fetchrow_array) {
say join ' ', map $_ // '--', @row;
}
__END__
Numbers of occurrences:
1 Shuttle Bus Operates 2016-08-06 09:00 2016-08-06 17:00 Bus Stops Bus Stops: Pine Island, Food Tent, Pink Clubhouse
1 Scope Making For Teens 2016-08-06 11:00 2016-08-06 12:30 Bunkhouse "Stargazer" Steve Dodson Ages 12-16
1 Scope Making Demo 2016-08-06 14:00 2016-08-06 16:00 Tent north of Pavilion Ken Slater Dobsonian Basics Dobsonian Basics
1 Scope Making Demo 2016-08-06 13:00 2016-08-06 14:00 Tent north of Pavilion Dave Groski Polishing & Figuring Polishing & Figuring
1 Scope Making Demo 2016-08-06 11:30 2016-08-06 12:00 Tent north of Pavilion Phil Rounseville Making Pitch Laps Making Pitch Laps
1 Scope Making Demo 2016-08-06 11:00 2016-08-06 11:30 Tent north of Pavilion Junie Esslinger Making Dental Stone Tools Making Dental Stone Tools
1 Scope Making Demo 2016-08-06 10:30 2016-08-06 11:00 Tent north of Pavilion Rick Hunter Fine Grinding Fine Grinding
1 Scope Making Demo 2016-08-06 10:00 2016-08-06 16:00 Tent north of Pavilion Ray Morits ATM Demo Hours
1 Scope Making Demo 2016-08-06 10:00:01 2016-08-06 10:30 Tent north of Pavilion Ray Morits Intro & Rough Grinding Intro & Rough Grinding
1 Registration Gate 2016-08-06 07:00 2016-08-06 19:00 Entry Gate Hours
</c>
<hr><P>
<a name="time-piece-bug"></a><h2>For [Corion]: [METAMOD://Time::Piece] bug</h2>
<c>
#!/usr/bin/perl
use warnings;
use strict;
use Time::Piece;
$ENV{TZ} = 'Europe/Berlin';
print 'Time::Piece'->VERSION, " $]\n";
for my $ts (qw( 2016-09-25 2016-10-31 )) {
$_ = $ts . 'T12:00:00';
my $datetime = 'Time::Piece'->strptime($_, '%Y-%m-%dT%H:%M:%S');
my $utc_offset = $datetime->strftime('%z');
chomp( my $system_offset = qx{ date +%z -d $_ } );
printf "%s - %s - %s - %s\n", $datetime, $utc_offset, $system_offset, $datetime->tzoffset;
}
__END__
1.20_01 5.018002
Sun Sep 25 12:00:00 2016 - +0100 - +0200 - 0
Mon Oct 31 12:00:00 2016 - +0100 - +0100 - 0
1.31 5.025007
Sun Sep 25 12:00:00 2016 - +0000 - +0200 - 0
Mon Oct 31 12:00:00 2016 - +0000 - +0100 - 0
</c>
<hr><P>
<h2>For [toolic]</h2>
<c>
#! /usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
say '1..3';
say 'ok ', $_ for 1 .. 2;
say 'not ok 3';
</c><P>
Run with <C>prove script.pl</C> .<P>
<hr>
<h2>Capture group repeat</h2>
<a href="https://rt.perl.org/Public/Bug/Display.html?id=128215">RT</a>,
<a href="http://stackoverflow.com/a/37379672/1030675">SO</a>
<c>
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
no warnings 'uninitialized';
say for 'abA' =~ /^( (?{warn "* [$1,$2,$3]\n"})
([ab]) (?{warn "\tL [$1,$2,$3]\n"})
|
([ab]) (?{warn "\t\tR [$1,$2,$3]\n"})
)*
((?{ warn "\t\t\t\\3 [$1,$2,$3]\n"})
\2
)
$/xi;
</c><P>
I'm not convinced using named captures makes it more readable:
<c>
say for 'abA' =~ /^
(?<whole>
(?<left>[ab])
|
(?<right>[ab])
)*
(\g{right})
$/xi;
</c><P>
<hr><P>
<h2>Tying array to support negative indices</h2><c>#!/usr/bin/perl
use warnings;
use strict;
{ package Array::Stretch;
use Tie::Array;
sub TIEARRAY { bless \ my $o, shift }
our $AUTOLOAD;
sub AUTOLOAD {
warn "** $AUTOLOAD: @_";
}
}
tie my @array, 'Array::Stretch';
@array = qw(a b c);
$array[-1] = 'A';
</c><hr>
<h2>Coverage History</h2>
<c>
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
use HTML::TableExtract;
use Time::Piece;
use XML::XSH2;
sub shell {
my $status = system @_;
die "@_: $status" if $status;
}
sub git_ready {
open my $GIT, '-|', qw{ git status --porcelain } or die $!;
my $ready = 1;
while (<$GIT>) {
$ready = 0;
}
return $ready
}
sub git_branch {
open my $GIT, '-|', qw{ git branch } or die $!;
my $branch;
while (<$GIT>) {
$branch = "$1", last if /^\* (.*)/
}
close $GIT or die $!;
return $branch
}
my @columns = qw( file stmt bran cond sub pod time total );
sub extract_coverage {
my ($commit, $n, $total) = @_;
open my $HTML, '<', "cover_db.$n/coverage.html" or die $!;
my $te = 'HTML::TableExtract'
->new(headers => [ @columns ]);
my $html = do { local $/ ; <$HTML> };
my $tables = $te->parse($html);
for my $row ($tables->rows) {
next unless 'Total' eq $row->[0];
$total->{ $commit->{id} }
= { date => $commit->{date},
map { $columns[$_] => $row->[$_] } 1 .. $#columns
};
}
}
sub add_navigation {
my ($n, $max, $commit) = @_;
{ package XML::XSH2::Map;
our $n = $n;
our $date = $commit->{date};
our $max = $max;
}
xsh << '__XSH__';
open { "cover_db.$n/coverage.html" } ;
register-namespace h http://www.w3.org/1999/xhtml ;
rm //h:a[@id = 'coverage-history-previous'
or @id = 'coverage-history-next'] ;
$date_header = //h:td[text() = 'Report Date:'] ;
if ($date_header) {
set $date_header/text() 'Commit Date:' ;
set $date_header/following-sibling::h:td[1]/text() $date ;
}
if (0 != $n) {
$prev := insert element a append //h:body ;
set $prev/@id 'coverage-history-previous' ;
set $prev/text() { "\x{2190}" } ;
set $prev/@href concat('../cover_db.', $n - 1, '/coverage.html') ;
insert text ' ' after $prev ;
}
if ($max != $n) {
$next := insert element a append //h:body ;
set $next/@id 'coverage-history-next' ;
set $next/text() { "\x{2192}" } ;
set $next/@href concat('../cover_db.', $n + 1, '/coverage.html');
}
save :f { "cover_db.$n/coverage.new" } ;
__XSH__
rename "cover_db.$n/coverage.new", "cover_db.$n/coverage.html" or die $!;
}
sub graph_data {
my ($total) = @_;
for my $id (keys %$total) {
my $date = $total->{$id}{date};
my $tz = substr $date, -5, 5, q();
my $tp = 'Time::Piece'->strptime($date, '%a %b %d %H:%M:%S %Y ');
my ($sign, $hours, $minutes) = $tz =~ /([-+])(\d\d)(\d\d)/;
$tp -= "${sign}1" * $minutes * 60 + $hours * 60 * 60;
$total->{$id}{UTC} = $tp->datetime;
}
open my $OUT, '>', 'coverages.data' or die $!;
for my $id ( sort { $total->{$a}{UTC} cmp $total->{$b}{UTC} }
keys %$total
){
my $commit = $total->{$id};
say {$OUT} join "\t", map 'n/a' eq $_ ? q() : $_,
@$commit{qw{ UTC sub stmt cond bran }};
}
close $OUT or die $!;
}
sub draw {
my ($output) = @_;
open my $GP, '|-', 'gnuplot' or die $!;
print {$GP} << '__GNUPLOT__';
set term png tiny
set output "coverages.png"
set key outside
set xdata time
set timefmt '%Y-%m-%dT%H:%M:%S'
plot "coverages.data" u 1:2 w lines t "subs", \
"" u 1:3 w lines t "statements", \
"" u 1:4 w lines t "conditions", \
"" u 1:5 w lines t "branches"
__GNUPLOT__
close $GP or die $!;
}
sub startup_check {
die 'Not a git repository' unless -d '.git';
die 'Devel::Cover not installed properly' unless qx{ which cover };
die 'gnuplot not found' unless qx{ which gnuplot };
die "Repository not clean. Maybe stash the changes?" unless git_ready();
}
sub get_commits {
my (@commits, %current);
open my $LOG, '-|', qw{ git log --stat } or die $!;
while (<$LOG>) {
if (/^commit (.*)/) {
if (delete $current{keep}) {
unshift @commits, { %current };
}
%current = ( id => "$1" );
} elsif (/^Date:\s+(.*)/) {
$current{date} = "$1";
} elsif (m=^ (?:lib|t)/=) {
$current{keep} = 1;
}
}
close $LOG or die $!;
return \@commits
}
sub make_or_build {
my ($makefile) = grep -f, qw( Makefile.PL Build.PL );
shell('perl', $makefile);
}
sub get_total {
my ($commits) = @_;
my %total;
for my $idx (reverse 0 .. $#$commits) {
my $commit = $commits->[$idx];
my $id = $commit->{id};
say STDERR @$commits - $idx, '/', scalar @$commits;
if (! -d "cover_db.$idx") {
system qw{ rm -f dump.t };
shell(qw{ git checkout }, $id);
make_or_build();
system qw{ cover -test };
rename 'cover_db', "cover_db.$idx" or die $!;
}
add_navigation($idx, $#$commits, $commit);
extract_coverage($commit, $idx, \%total);
}
return \%total
}
sub good_bye {
print << "__EOF__"
Done.
coverage.png created.
file://$ENV{PWD}/cover_db.0/coverage.html
__EOF__
}
sub main {
startup_check();
my $commits = get_commits();
my $branch = git_branch();
my $total = get_total($commits);
shell(qw{ git checkout }, $branch);
graph_data($total);
draw();
good_bye();
}
main();
</c><P>
<hr>
<h2>Matching differently encoded strings</h2>
<p>(for [shmem])
<c>
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
use Encode;
my $iso8859 = join '', map chr, 191 .. 207,
209 .. 214,
216,
217 .. 221,
223 .. 239,
241 .. 246,
248 .. 253;
my $utf8 = encode('utf8', decode('latin1', join '|', split //, $iso8859));
my $valid = qr/ ^ (?: [[:print:]$iso8859] | $utf8 ) $ /x;
my $o_uml = decode('latin1', "\N{LATIN CAPITAL LETTER O WITH DIAERESIS}");
my $o_l1 = encode('latin1', $o_uml);
my $o_utf8 = encode('utf8', $o_uml);
say 'bytes' if $o_uml =~ /$valid/;
say 'latin' if $o_l1 =~ /$valid/;
say 'utf8' if $o_utf8 =~ /$valid/;
say 'yup' if "\x82" =~ /$valid/; # chr 130
</c>
<hr><P>
<h2>Instance and class methods</h2>
<c>
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
{ package Method::Types;
use Carp;
use Attribute::Handlers;
sub handler {
my ($package, $symbol, $ref, $attr, $data, $phase) = @_;
die if 'CHECK' ne $phase;
my $method_type = { Class => 'static',
Instance => 'instance',
}->{$attr};
{ no warnings 'redefine';
*$symbol = sub {
croak("Can't call $method_type method '", *{$symbol}{NAME},
"' on ", ref $_[0] ? 'an object' : 'a class',
".\n") if ref $_[0] xor 'instance' eq $method_type;
goto $ref
};
}
}
sub Class : ATTR(CODE) { handler(@_) }
sub Instance : ATTR(CODE) { handler(@_) }
}
{ package Named;
use parent -norequire => 'Method::Types';
sub new : Class {
bless {}, shift
}
sub set_name : Instance {
$_[0]->{name} = $_[1]
}
sub get_name : Instance {
shift->{name}
}
}
my $o = 'Named'->new;
$o->set_name('John');
say $o->get_name;
eval {$o->new; 1} or warn $@;
eval {'Named'->get_name; 1} or warn $@;
</c><P>
<hr><P>
<h2>Tied scalar remembereing previous values</h2>
[Discipulus] mmh.. could a tied scalar know his previous value?
<p>
In this example, the variable reports the previous value when assigned.
<c>
#!/usr/bin/perl
use warnings;
use strict;
use Syntax::Construct '//';
{ package Previous;
use Tie::Scalar;
use parent -norequire => 'Tie::StdScalar';
sub TIESCALAR { bless \ my $o, shift }
sub STORE {
my ($self, $value) = @_;
warn 'I was ', $$self // 'undefined', "\n";
$$self = $value;
}
}
tie my $p, 'Previous';
$p = $_ for 'a' .. 'z';
</c>
<p>
<hr>
<h2>Magic date</h2>
<p>[[chacham]] Yesterday was 3/24/2015 using all numbers 0-5. In just over a week it'll happen again.
<c>#! /usr/bin/perl
use warnings;
use strict;
use Time::Piece;
use Time::Seconds qw{ ONE_DAY };
sub is_magical {
my $s = shift;
my %chars;
undef @chars{ split //, $s };
my ($first, $last) = (sort keys %chars)[0, -1];
return (keys %chars == length $s
and $last - $first + 1 == length $s)
}
my $t = 'Time::Piece'->strptime('2015-01-01', '%Y-%m-%d');
while () {
print $t->ymd, "\n" if is_magical(join q(), $t->mon, $t->mday, $t->year);
$t = $t + ONE_DAY;
}
</c>
<hr>
<a name="deparse"></a>
<h2>Deparse weirdness (Inspired by yitzchak)</h2>
<c>(1)$ perl -MO=Deparse -e 'do("foo")->{bar};'
do $foo{'bar'};
-e syntax OK
(2)$ perl -MO=Deparse -e '(do "foo")->{bar};'
do('foo')->{'bar'};
-e syntax OK
(3)$ perl -MO=Deparse -Mstrict -e 'do("foo")->{bar};'
Global symbol "%foo" requires explicit package name at -e line 1.
-e had compilation errors.
use strict 'refs';
do $<none>::foo{'bar'};
ERROR CODE: [34]
(4)$ perl -MO=Deparse -Mstrict -e '(do "foo")->{bar};'
use strict 'refs';
do('foo')->{'bar'};
-e syntax OK
</c>
<p>
So, (3) is not permitted under [doc://strict]. (4) is permitted, but [doc://B::Deparse|deparses] to (3). What's going on here? (v5.14.4 under cygwin)
<hr>
<h2>For pankaj_it09</h2>
<c>
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
my $number = '343243-23423*234-2342-3';
my @separators = $number =~ /([^0-9])/g;
my %uniq;
undef @uniq{@separators};
say 1 == keys %uniq ? 'Same' : 'Different';
</c>
<hr>
<h2>Grouping similar elements</h2>
<p>For [mohan2monks]:
<c>
#!/usr/bin/perl
use warnings;
use strict;
use Data::Dumper;
my @array = qw(AB AB CD AB AB AB);
my @result = [ shift @array ];
for (@array) {
if ($_ eq $result[-1][0]) {
push @{ $result[-1] }, $_;
} else {
push @result, [ $_ ];
}
}
print Dumper \@result;
</c>
<hr>
The end.<!-- Wiki2Monks {"version":1.161} -->