#!/usr/bin/perl -w

# This script opens up an emacs window with the given program running
# under a debugger, all automagic-like.
#
# Usage: debug <program> <args>...
#
# Various environment variables can affect the operation. Let's see...
#   $DBG : set to qr/EXPRESSION/ to only fire up emacs for programs
#          that match the given regex.
#   $GDB_INITFILE : gdb will execute this file when it starts up.
#          There are better ways of doing this, you know.
#   $GDB_INITSTRING : execute the given gdb command at startup.
#   $GDB_INTERACTIVE : set this to any nonempty value to have gdb
#          pause before running the program.
#
# Most of those options don't work or aren't relevant for the perl
# debugger.

my @EMACS = qw(emacs);
if ($ENV{DEBUG_EDITOR}) {
  @EMACS = $ENV{DEBUG_EDITOR} =~ /(\".*?\"|\'.*?\'|\S+)/g;
}

my ($COMMAND, @args) = @ARGV;

if ($COMMAND !~ m!/!) {
  chomp($COMMAND = qx/which $COMMAND/);
}

chomp($ENV{CWD} = `pwd`);

# Check whether we should skip debugging this invocation
# (if DBG is set to qr/something/ that doesn't match the command line)
if ($ENV{DBG} && $ENV{DBG} =~ /qr/) {
        my $pattern = eval $ENV{DBG};
        if (join(" ", @ARGV) !~ $pattern) {
            exec(@ARGV);
        }
}

my $debug_perl;
if ($COMMAND =~ /\bperl$/) {
    $debug_perl = 1;
    $COMMAND = $args[0];
} elsif (`file -L $COMMAND` =~ /perl/) {
    $debug_perl = 1;
    unshift(@args, $COMMAND);
}

sub protect {
    local $_ = shift;
    s/([\'\"\\])/\\$1/g;
    return $_;
}

if ($debug_perl) {
  shift(@args);

  unlink(glob("/tmp/debug-*-args"));
  my $argfile = "/tmp/debug-$$-args";
  open(ARGFILE, ">$argfile") or die "create $argfile: $!";
  print ARGFILE "$_\n" foreach (@args);
  close ARGFILE;

  exec(@EMACS, "--eval", qq[(progn (perldb "perl $COMMAND") (insert-string "chdir('$ENV{CWD}')") (comint-send-input) (insert-string "chomp(\@DB::ARGS=`cat $argfile`)") (comint-send-input) (insert-string "\@ARGV=\@DB::ARGS") (comint-send-input))]);
}

# Set the arguments
my $fname = "/tmp/debug-$$-args";
open(ARGS, ">$fname") or die "create $fname: $!";
my $str = "set args ";
foreach (@args) {
#  s/\\/\\\\/g;
  s/\'/\\\'/g;
  $str .= "'$_' ";
}
chop($str) if @args;
print ARGS $str, "\n";
my $init_eval = <<"END";
(insert-string "source $fname") (comint-send-input) (insert-string "cd $ENV{CWD}") (comint-send-input)
END

# If env var GDB_INITFILE set, load it into gdb on startup
if ($ENV{GDB_INITFILE}) {
    print STDERR "Loading init file $ENV{GDB_INITFILE}\n";
    $init_eval .= <<"END";
 (insert-string "source $ENV{GDB_INITFILE}") (comint-send-input)
END
}

# If env var GDB_INITSTRING set, give it to gdb
if ($ENV{GDB_INITSTRING}) {
    print STDERR "Sending gdb command $ENV{GDB_INITSTRING}\n";
    $init_eval .= <<"END";
 (insert-string "$ENV{GDB_INITSTRING}") (comint-send-input)
END
}

# If env var GDB_INTERACTIVE or DBG eq 'wait', let the user run the gdb session
unless ($ENV{GDB_INTERACTIVE} || ($ENV{DBG} || '') eq 'wait') {
    print STDERR "Running gdb immediately\n";
    $init_eval .= <<"END";
 (insert-string "run") (comint-send-input)
END
}

exec(@EMACS, "--eval", "(progn (gdb \"gdb $COMMAND\") $init_eval)");

# Copyright (c) 2002-4 by Steve Fink. All rights reserved.
#
# You may do anything you want with this script, as long as you don't
# use it to directly or indirectly cause harm to any mythical
# creatures. Only real creatures may be harmed by the running of this
# script. Oh, and you can't remove my copyright notice either, no
# matter how much you mutate the script itself.
#
# But if you're nice, you'll properly document all the funky options,
# clean it up, and send it back to me at steve@fink.com. And you seem
# like a really nice person to me.