#!/usr/bin/perl -w

$doc = <<'';
# perl editor : edit files in place
#
# ped edits files via perl command(s) in place and saves a backup file.
#
# Files are loaded and edited in one chunk, not line by line.
# Symbolic and hard links are handled correctly, in opposition to
# "sed -i" or "perl -p -i -e" which breaks links.
# A file is assigend to $_, which you can modify with any Perl commands.
# ped can also edit STDIN in one chunk (multiline edit).
#
# Hint: use s/^.../.../gm to modify each line begin.

# 2016-09-11 keep hard and soft links
# 2016-09-14 added option -q

use Getopt::Std;

$0 =~ s:.*/::;
local $/;

$usage =
  "usage: $0 [-n] [-v] [-q] 'perl command(s)' file(s)\n".
  "options: -n  no backup\n".
  "         -v  verbose mode\n".
  "         -q  quiet mode (no warnings)\n".
  "example: $0 's/ /_/g' *.txt\n".
  "\n".
  "usage: ... | $0 'perl command(s)'\n".
  "example: ifconfig | $0 's/(.+?)\\n\\n/{\$1\\n}\\n/sg'\n";

$opt_h = $opt_n = $opt_v = $opt_q = 0;
getopts('hnvq') or die $usage;

if ($opt_h) {
  print $doc,"\n",$usage;
  exit;
}

$opt_q = 0 if $opt_v;

$cmd = shift or die $usage;

if ($vv = pathsearch('vv') and slurp($vv) !~ /visual versioning/) {
  $vv = '';
}

$STDOUT = '';
tie *STDOUT => "Buffer",\$STDOUT;

if (@ARGV) {
  foreach $file (@ARGV) {
    unless (-e $file) {
      $status = 2;
      warn "$0: $file does not exist\n";
      next;
    }
    unless (-f $file) {
      $status = 3;
      warn "$0: $file is not a regular file\n";
      next;
    }
    unless (-w $file) {
      $status = 4;
      warn "$0: no write permission for $file\n";
      next;
    }
    $file = realfilename($file) if -l $file;
    @stat = stat $file;
    $fid = $stat[0].':'.$stat[1];
    if ($fhl = $file{$fid}) {
      if (not $opt_q and $file ne $fhl) {
        warn "$0: ignoring hard link $file of $fhl\n";
      }
      next;
    }
    $file{$fid} = $file;
    unless (open $file,'+>>',$file) {
      $status = $?;
      warn "$0: cannot write $file - $!\n";
      next;
    }
    seek $file,0,0;
    $_ = $__ = <$file>;
    eval $cmd;
    $_ .= $STDOUT;
    if ($@) {
      $status = 2;
      warn "$0: $@";
    } elsif ($_ eq $__) {
      warn "$0: $file not modified\n" if $opt_v;
    } else {
      unless ($opt_n) {
        if ($vv) {
          if ($opt_v) {
            print STDERR "$0: creating backup file: ";
            system qw'vv -vs',$file
          } else {
            system qw'vv -sq',$file
          }
        } else {
          warn "$0: creating backup file $file~\n" if $opt_v;
          system qw'rsync -aA',$file,"$file~";
        }
      }
      truncate $file,0;
      seek $file,0,0;
      print {$file} $_;
      $status ||= 0;
      warn "$0: $file modified\n" if $opt_v;
    }
    close $file;
  }
  if (defined $status) { exit $status } else { exit 99 }
} else {
  $_ = <STDIN>;
  eval $cmd;
  die "$0: $@" if $@;
  $^W = 0;
  untie *STDOUT;
  $_ .= $STDOUT;
  print;
  exit;
}


# resolve symlinks
sub realfilename {
  my $file = shift;

  if (-e $file) {
    if (-l $file) {
      my $link = readlink($file);
      if ($link !~ /^\// and $file =~ m:(.*/).:) {
        $link = $1 . $link;
      }
      return realfilename($link);
    } else {
      return $file;
    }
  } else {
    return undef;
  }
}


sub pathsearch {
  my $prg = shift;

  foreach my $dir (split(':',$ENV{PATH})) {
    return "$dir/$prg" if -x "$dir/$prg";
  }
}


sub slurp {
  my $file = shift;
  local $_;
  local $/;

  if (open $file,$file) {
    $_ = <$file>;
    close $file;
  }

  return $_;
}


# tie STDOUT to buffer variable (redefining print and printf)
package Buffer;

sub TIEHANDLE {
  my ($class,$buffer) = @_;
  bless $buffer,$class;
}

sub PRINT {
  my $buffer = shift;
  $$buffer .= $_ foreach @_;
}

sub PRINTF {
  my $buffer = shift;
  my $fmt = shift @_;
  $$buffer .= sprintf($fmt,@_);
}

1;
