use strict; use warnings;
use Data::Dumper;

=for comment

 scanl f q ls = q : case ls of
     []   -> []
     x:xs -> scanl f (f q x) xs

=cut

sub scanl {
    my ($f, $seed, @list)=@_;

    my @tail = @list[ 1 .. $#list ] ;

    my @rest = scalar @list ? scanl($f, $f->($seed, $list[0]), @tail) 
+: ();

    ($seed, @rest);
}


my @lis = (4,2,4);


sub add { $_[0] + $_[1] }
sub divide { $_[0] / $_[1] }

my @result = scanl \&divide, 64, @lis;

warn Dumper(\@result);

 @result = scanl \&divide, 3, ();

warn Dumper(\@result);

use List::Util 'max';

 @result = scanl \&List::Util::max, 5, (1 .. 7) ;

warn Dumper(\@result);
[download]

perl -MFile::MMagic -e '$mm=File::MMagic->new; for(glob("*")){$res=$mm
+->checktype_filename($_);print "$_:\t$res\n"}'
[download]

    use Win32::Process;
    use Win32;
    use Win32::Shortcut;
    my $link = Win32::Shortcut->new;
    $link->Load("D:\\Program Files\\Putty\\start pageant.lnk");
    $link->Close();
    # print "Shortcut to: $link->{Path} $link->{Arguments}\nDirectory:
+ $link->{WorkingDirectory}";
    Win32::Process::Create(my $process,
        $link->{Path},
        qq("$link->{Path}" $link->{Arguments}),
        $link->{ShowCmd},
        NORMAL_PRIORITY_CLASS,
        $link->{WorkingDirectory})
      or die Win32::FormatMessage( Win32::GetLastError() );

    require Win32::GuiTest;  # while we're waiting...
    my $result = $process->Wait(2_000);  # returns immediately if page
+ant was running
                                         # times out if it just got st
+arted up
    while(1) {
        my @windows = Win32::GuiTest::FindWindowLike(0, qr/^Pageant:\s
++Enter\s+Passphrase/i)
            or last;
        sleep 1;
    }
[download]

#!/usr/bin/perl

{ $n = shift || die "Usage: perl nosemicolon.pl NUMBER\n" }

sub fib {
    if ($_[0] < 2) {
        $_[0]
    } else {
        fib($_[0] - 1) + fib($_[0] - 2)    
    }
}

{ print "Fibonacci numbers from 0 to $n are as follows:\n" }

for (0 .. $n) {
    print "fib($_) = ", fib($_), "\n"
}

print "Thanks for using this software!\n"
[download]

sub methodA { $_ = (caller(0))[3];s/.*\://; @_ > 1 ? $_[0]->{$_} = $_[
+1] : $_[0]->{$_} };
[download]

#!/usr/bin/perl

my@wordsInOrder;
while (<>) {
    foreach ("$_" =~ m/\w+/g) {
        push @wordsInOrder, lc($_);
    }
}

my$trypHash = {};
for ($i=0;$i < scalar(@wordsInOrder)-2; $i++) {
    $trypHash->{$wordsInOrder[$i]." ".$wordsInOrder[$i+1]." ".$wordsIn
+Order[$i+2]} += 1;
}
my$dupeHash = {};
for ($i=0;$i < scalar(@wordsInOrder)-1; $i++) {
    $dupeHash->{$wordsInOrder[$i]." ".$wordsInOrder[$i+1]} += 1;
}
my$oneHash = {};
for ($i=0;$i < scalar(@wordsInOrder); $i++) {
    $oneHash->{$wordsInOrder[$i]} += 1;
}

foreach my$one (sort {$oneHash->{$b} <=> $oneHash->{$a}} keys %{$oneHa
+sh} ) {
    print "$one\n";
    foreach my$two (sort {$dupeHash->{$b} <=> $dupeHash->{$a}} keys %{
+$dupeHash} ) {
        next unless $two =~ m/^$one/;
        print "\t$two\n";
        foreach my$three (sort {$trypHash->{$b} <=> $trypHash->{$a}} k
+eys %{$trypHash} ) {
            next unless $three =~ m/^$two/;
            print "\t\t$three\n";
        }
    }
}
[download]

#!perl
use strict;
use warnings;
use Config '%Config';
use Judy::HS qw( Set );
use Judy::L qw( First Next );
use Judy::Mem qw( Peek Ptr2String2 );

use constant LONGSIZE => 0+$Config{longsize};

# Load $hs with a pile of data.
my $hs;
@ARGV = "$ENV{HOME}/Documents/Political Data/Secretary of state/Statew
+idevoters13102.txt";
while (<>) {
  Set( $hs, $_, $. );
}


# Nested printing.
our $P = -1;
sub p { print ' ' x ( 4 * $P ), @_ }


# Loop over JudyL array, each entry contains all strings of length $le
+ngthKey.
my ( undef, $lengthL, $lengthKey ) = First( $hs, 0 );
while ( defined $lengthKey ) {
  local $P = 1+$P;
  p( "LENGTH: $lengthKey\n" );


  # Loop over JudyL array, each entry contains all strings that map to
+ the same $hashKey.
  my $hashCount = 0;
  my ( undef, $hashL, $hashKey ) = First( $lengthL, 0 );
  while ( defined $hashKey ) {
    local $P = 1+$P;
    p( sprintf "HASH @{[ ++ $hashCount ]}: 0x%x\n", $hashKey );


    # Recurse down through JudyL until I find the key/value.
    dumpLTree( $hashL );

    ( undef, $hashL, $hashKey ) = Next( $lengthL, $hashKey );
  }

  ( undef, $lengthL, $lengthKey ) = Next( $hs, $lengthKey );
}


sub dumpLTree {
  my ( $l ) = @_;

  # Find the stored key/values.
  if ( Judy::JLAP_INVALID & $l ) {
    $l &= ~Judy::JLAP_INVALID;
    local $P = 1+$P;


    # Unpack the C struct containing my key value. The value is the fi
+rst 
    my $value = Peek( $l );
    my $str   = Ptr2String2( LONGSIZE + $l, $lengthKey );
    p( "{Value: $value, String: $str}\n" );
  }
  else {

    # Go deeper.
    my ( undef, $innerL, $key ) = First( $l, 0 );
    while ( defined $key ) {
      local $P = 1+$P;
      p( "str: $key\n" );

      dumpLTree( $key );
      ( undef, $innerL, $key ) = Next( $l, $key );
    }
  }
}
[download]

#!c:/Perl/bin/Perl.exe
#
# corrector.pl
# changes words inside text files
# placed in the win directory C:\filestochange
# which is supposed to contain text files
#

my $dir_to_process = "C:\\filestochange";
opendir DH, $dir_to_process or die "Cannot open $dir_to_process: $!";

foreach $file (readdir DH) {
  unless ($file eq "." || $file eq ".." || $file eq "discarded" || $fi
+le eq "tmp") {
    print "in $dir_to_process $file is processed\n";
    open (INFILEHANDLE, "C:\\filestochange\\$file") or die "error open
+ing";
    open (OUTFILEHANDLE, ">C:\\filestochange\\tempfile8000") or die "e
+rror opening";
    while (<INFILEHANDLE>) {
      # chomp;
      s/this/that/; # substututes this with that
      s/one/two/; # substututes one with two
      print OUTFILEHANDLE;
    }
    close INFILEHANDLE;
    close OUTFILEHANDLE;
    rename "C:\\filestochange\\tempfile8000","C:\\filestochange\\$file
+";
  }
}

closedir DH;

print "\nDone (press enter key)\n";
$line = <STDIN>;
[download]

#!/usr/bin/perl -w
use strict;

die "Usage: ", $0 =~ /([^\/]+)$/, " <numeric_string>\n"
    unless @ARGV && $ARGV[0] =~ /^\d+$/;
my ($c, @list);
for (reverse split //, $ARGV[0]){
    unshift @list, $c++ % 3 || $c == 1 ? $_ : "$_,";
}
print @list;

# Or, instead of "cheating" with an unquoted list, we could
# aggregate to a string. It's not quite as neat, though. :(
#
# my ($c, $out);
# for (reverse split //, $ARGV[0]){
#     $out = $c++ % 3 || $c == 1 ? "$_$out" : "$_,$out";
# }
# print "$out\n";
[download]