Move old scripts into a subdir

misc/collapse

@@ -0,0 +1,23 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings FATAL => 'all';
+
+my ( $key, @values ) = next_record();
+
+while ( defined $key ) {
+    my ( $next_key, @next_values ) = next_record();    
+    if ( defined $next_key and $next_key eq $key ) {
+        push @values, @next_values;
+    }
+    else {
+        print join( "\t", $key, @values ) . "\n";
+        $key = $next_key;
+        @values = @next_values;
+    }    
+}
+
+sub next_record {
+    defined( local $_ = <> ) or return;
+    chomp; split;
+}

misc/mtail

@@ -0,0 +1,51 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings FATAL => 'all';
+
+use IO::Pipe;
+
+my $pipe = IO::Pipe->new();
+
+map { tail($_) } @ARGV;
+
+$pipe->reader();
+
+while (<$pipe>) {
+  print;
+}
+
+sub parse_host_file {
+  my $spec = shift;
+  if ( my ( $h, $f ) = $spec =~ m/^([^:]+):(.+)$/ ) {
+    return ( $h, $f );
+  }
+  else {
+    return ( undef, $spec );
+  }
+}
+
+sub tail {
+  my ( $spec ) = @_;
+  my ( $host, $file ) = parse_host_file($spec);
+  my $cmd = $host ? ['ssh', $host, 'tail', '-F', $file ] : ['tail', '-F', $file ];
+  my $prefix = $host ? "$host: " : "";
+  my $pid = fork();
+  if ( $pid ) { # parent
+    return $pid;
+  }
+  elsif ( defined($pid) ) { # child
+    $pipe->writer();
+    open( my $fh, '-|', @$cmd ) or exit 255;
+    while ( <$fh> ) {
+      s/^/$prefix/;
+      $pipe->print($_);
+      $pipe->flush();
+    }
+    close($fh);
+    exit 0;
+  }
+  else {
+    die "Failed to tail $spec (fork failed): $!";
+  }
+}

misc/new-profile

@@ -0,0 +1,32 @@
+#!/bin/bash
+#
+# This is based on an idea stolen from Oliver; see his great blog post
+# http://blogs.perl.org/users/oliver_gorwits/2011/07/locallibs-for-dist-development.html
+# for the rationale.
+#
+# This script works hand-in-hand with switch-profile.
+# 
+
+set -e
+
+if [ -z "$1" ]
+  then
+    echo 'Pass the profile name, please' >&2
+    exit 2
+fi
+
+echo "Creating local::lib for $1 ..."
+sleep 3
+
+test -d "${HOME}/perl-profiles" || mkdir -v "${HOME}/perl-profiles"
+PROFILE_DIR="${HOME}/perl-profiles/$1"
+
+curl -L http://cpanmin.us/ | perl - --notest --quiet --local-lib-contained "${PROFILE_DIR}" \
+    App::cpanminus \
+    Dist::Zilla \
+    App::local::lib::helper
+
+mkdir -p "${PROFILE_DIR}/etc"
+cat > "${PROFILE_DIR}/etc/bashrc" <<EOF
+export PS1="\u@\h:\w [\$PROFILE]\\\$ "
+EOF

misc/svn-find.pl

@@ -0,0 +1,68 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings FATAL => 'all';
+
+use Getopt::Long;
+
+GetOptions(
+    'type=s'      => \my $type,
+    'max-depth=i' => \my $max_depth,
+    'min-depth=i' => \my $min_depth,
+    'name=s'      => \my $name,
+) and @ARGV or die "Usage: $0 [--type=f|--type=d] [--max-depth=N] [--min-depth=N] [--name=NAME] REPOS_URL ...\n";
+
+for ( @ARGV ) {
+    $_ .= '/' unless $_ =~ m{/$};
+    svn_find( $_, 0 );
+}
+
+sub is_match {
+    my $path = shift;
+
+    my ( $basename, $is_dir ) = $path =~ m{([^/]+)(/?)$};                                           
+    
+    if ( defined $type ) {
+        if ( $type eq 'f' ) {
+            return if $is_dir;
+        }
+        elsif ( $type eq 'd' ) {
+            return unless $is_dir;
+        }
+    }
+
+    if ( defined $name and $name ne $basename ) {
+        return;
+    }
+
+    return 1;    
+}
+
+sub svn_find {
+    my ( $repos_url, $depth ) = @_;
+
+    if ( defined $max_depth and $depth > $max_depth ) {
+        return;
+    }
+    
+    my @dirents = svn_ls( $repos_url );
+
+    if ( ( not defined $min_depth ) or $depth >= $min_depth ) {
+        print $repos_url . $_ . "\n" for grep { is_match($_) } @dirents;
+    }
+    
+    for my $dir ( grep m{/$}, @dirents ) {
+        svn_find( $repos_url . $dir, $depth + 1 );
+    }    
+}
+
+sub svn_ls {
+    my $svn_url = shift;
+    
+    open( my $ls, '-|', 'svn', 'ls', $svn_url )
+        or die "svn ls $svn_url failed";
+    map { chomp; $_ } <$ls>;
+}
+
+
+

misc/switch-profile

@@ -0,0 +1,33 @@
+#!/bin/bash
+#
+# This is based on an idea stolen from Oliver; see his great blog post
+# http://blogs.perl.org/users/oliver_gorwits/2011/07/locallibs-for-dist-development.html
+# for the rationale.
+#
+# This script works hand-in-hand with new-profile.
+# 
+
+if [ -z "$1" ]
+  then
+    echo 'Pass the profile name, please'
+    echo 'Valid profiles:'
+    for DIRENT in ${HOME}/perl-profiles/*; do
+        if test -d "${DIRENT}"; then
+            PROFILE=${DIRENT##*/}
+            echo "    ${PROFILE}"
+        fi
+    done
+    exit
+fi
+
+PROFILE="$1"
+
+if ! test -d "${HOME}/perl-profiles/${PROFILE}"; then
+    echo "No such profile ${PROFILE}" >&2
+    exit 2
+fi
+
+export PROFILE
+exec env PATH=${HOME}/bin:/bin:/usr/bin PERL5LIB= \
+    "${HOME}/perl-profiles/${PROFILE}/bin/localenv" \
+    /bin/bash --rcfile "${HOME}/perl-profiles/${PROFILE}/etc/bashrc"

misc/tk-comm

@@ -0,0 +1,185 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings FATAL => 'all';
+
+use Tk;
+use IO::File;
+use List::Compare;
+require Tk::ROText;
+
+my ( $filename_A, $filename_B ) = ( '', '' );
+
+my $mw = MainWindow->new;
+$mw->title( 'Compare Files' );
+
+add_choose_file_frame( 'File A', \$filename_A );
+add_choose_file_frame( 'File B', \$filename_B );
+
+my $button_frame = $mw->Frame->pack;
+$button_frame->Button( -text => "File A only", -command => \&file_A_only )->pack( -side => 'left' );
+$button_frame->Button( -text => "File B only", -command => \&file_B_only )->pack( -side => 'left' );
+$button_frame->Button( -text => "Both files",  -command => \&both_files  )->pack( -side => 'left' ) ;
+$button_frame->Button( -text => "Quit",        -command => sub { $mw->destroy } )->pack;
+
+MainLoop;
+
+sub add_choose_file_frame {
+    my ( $label, $var_ref ) = @_;
+
+    my $frame = $mw->Frame->pack( -side => 'top', -fill => 'x' );
+    $frame->Label( -text => $label )->pack( -side => 'left' );
+    $frame->Entry( -width => 30, -textvariable => $var_ref )->pack( -side => 'left' );
+    $frame->Button( -text => 'Browse', -command => choose_file( $var_ref ) )->pack;
+}
+
+sub choose_file {
+    my $var_ref = shift;
+
+    my @types = (
+        ['All Files',                 '*',             ],
+        ['Text Files',                ['.txt', '.text']],
+    );
+    
+    return sub {
+        ${$var_ref} = $mw->getOpenFile( -filetypes => \@types );
+   };
+}
+
+sub file_A_only {
+    my $lc = compare_files()
+        or return;
+    show_results( 'File A only', $lc->get_unique_ref );
+}
+
+sub file_B_only {
+    my $lc = compare_files()
+        or return;
+    show_results( 'File B only', $lc->get_complement_ref );
+}
+
+sub both_files {
+    my $lc = compare_files()
+        or return;
+    show_results( 'Both files', $lc->get_intersection_ref );
+}
+
+sub show_results {
+    my ( $title, $results ) = @_;
+
+    my $results_window = $mw->Toplevel( -title => $title );
+    my $text = $results_window->Scrolled( 'ROText', -wrap => 'none', -scrollbars => 'osoe' )->pack;
+    $text->insert( 'end', join "\n", @{$results} );
+
+    $results_window->Button(
+        -text    => 'Close',
+        -command => sub { $results_window->destroy }
+    )->pack( -side => 'right' );
+    
+    $results_window->Button(
+        -text    => 'Save',
+        -command => sub { save_results( $results_window, $results ) && $results_window->destroy }
+    )->pack( -side => 'right' );
+}
+
+sub save_results {
+    my ( $rw, $results ) = @_;
+
+    my $filename = $rw->getSaveFile();
+    unless ( defined $filename and length $filename ) {
+        popup_error( "You must specify a file for the results to be saved" );
+        return;
+    }
+    
+    my $fh = IO::File->new( $filename, O_RDWR|O_CREAT|O_TRUNC, 0644 );
+    unless ( $fh ) {
+        popup_error( "Failed to open $filename for writing: $!" );
+        return;
+    }
+
+    for my $r ( @{$results} ) {
+        $fh->print( "$r\n" );
+    }
+    
+    $fh->close;
+
+    $rw->messageBox( -title => 'Saved', -message => "Results saved to $filename", -type => 'ok' );
+
+    return 1;
+}
+
+sub compare_files {
+    my ( $A, $B ) = read_files()
+        or return;
+
+    return List::Compare->new( $A, $B );
+}
+
+sub read_files {
+
+    unless ( defined $filename_A and length $filename_A ) {
+        popup_error( "File A must be specified" );
+        return;
+    }
+
+    unless ( defined $filename_B and length $filename_B ) {
+        popup_error( "File B must be specified" );
+        return;
+    }
+    
+    my $content_A = slurp_lines( $filename_A )
+        or return;
+
+    my $content_B = slurp_lines( $filename_B )
+        or return;
+
+    return ( $content_A, $content_B );
+}
+
+sub slurp_lines {
+    my $filename = shift;
+
+    my $fh = IO::File->new( $filename, O_RDONLY );
+    unless ( $fh ) {
+        popup_error( "Failed to open $filename: $!" );
+        return;
+    }
+
+    local $/ = undef;
+
+    my $content = <$fh>;
+
+    [ split qr/\r\n|\r|\n/, $content ];
+}
+
+sub popup_error {
+    my $error = shift;
+    $mw->messageBox( -title => 'Error', -message => $error, -type => 'ok' );
+}
+
+__END__
+
+=head1 NAME
+
+tk-comm
+
+=head1 DESCRIPTION
+
+B<tk-comm> is a graphical version of the standard Unix L<comm(1)>
+command. Unlike L<comm(1)>, it does not require files to be sorted,
+and it handles Unix, Windows, and Mac line endings transparently.
+
+=head1 SEE ALSO
+
+L<comm(1)>, L<List::Compare>
+
+=head1 AUTHOR
+
+Ray Miller E<lt>ray@1729.org.ukE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2012 Ray Miller.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.

misc/yaml2csv

@@ -0,0 +1,25 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings FATAL => 'all';
+
+use YAML::Any;
+use CSV::Writer;
+use Getopt::Long;
+
+my @columns;
+
+GetOptions(
+    'columns=s@' => sub {
+        my ( $opt, $value ) = @_;
+        push @columns, split qr{\s*,\s*}, $value;
+    }
+) and @columns > 0
+    or die "Usage: $0 [--columns=...]\n";
+
+my $csv = CSV::Writer->new( columns =>  \@columns );
+$csv->write( $csv->columns );
+
+for my $d ( YAML::Any::LoadFile( \*STDIN ) ) {
+    $csv->write( $d );
+}