use Carp;
use List::Util;
+use Hash::Merge 'merge';
+
+Hash::Merge::specify_behavior({
+ SCALAR => {
+ SCALAR => sub { $_[1] },
+ ARRAY => sub { [ $_[0], @{$_[1]} ] },
+ HASH => sub { $_[1] },
+ },
+ ARRAY => {
+ SCALAR => sub { $_[1] },
+ ARRAY => sub { $_[1] },
+ HASH => sub { $_[1] },
+ },
+ HASH => {
+ SCALAR => sub { $_[1] },
+ ARRAY => sub { [ values %{$_[0]}, @{$_[1]} ] },
+ HASH => sub { Hash::Merge::_merge_hashes( $_[0], $_[1] ) },
+ },
+}, 'My Behavior' );
use base 'Class::Accessor::Grouped';
__PACKAGE__->mk_group_accessors( simple => $_ ) for qw(
newline indent_string indent_amount colormap indentmap fill_in_placeholders
+ include_caller caller_depth
);
# Parser states for _recurse_parse()
my %profiles = (
console => {
+ caller_depth => 0,
fill_in_placeholders => 1,
indent_string => ' ',
indent_amount => 2,
indentmap => { %indents },
},
console_monochrome => {
+ caller_depth => 0,
fill_in_placeholders => 1,
indent_string => ' ',
indent_amount => 2,
indentmap => { %indents },
},
html => {
+ caller_depth => 0,
fill_in_placeholders => 1,
indent_string => ' ',
indent_amount => 2,
};
sub new {
- my ($class, $args) = @_;
+ my $class = shift;
+ my $args = shift || {};
my $profile = delete $args->{profile} || 'none';
- my $data = {%{$profiles{$profile}}, %{$args||{}}};
+ my $data = merge( $profiles{$profile}, $args );
bless $data, $class
}
return $keyword
}
-
my %starters = (
select => 1,
update => 1,
my ($self, $bindargs) = @_;
if ($self->fill_in_placeholders) {
- my $val = pop @{$bindargs};
+ my $val = pop @{$bindargs} || '';
$val =~ s/\\/\\\\/g;
$val =~ s/'/\\'/g;
return qq('$val')
return '?'
}
+sub _caller_info {
+ my ($self, $depth) = @_;
+
+ return '' if $depth != 1 or !$self->include_caller;
+
+ my @caller_info = caller($self->caller_depth + 0);
+
+ " at $caller_info[1] line $caller_info[2].";
+}
+
sub unparse {
- my ($self, $tree, $bindargs, $depth) = @_;
+ my ($self, $tree, $bindargs, $indent, $depth) = @_;
- $depth ||= 0;
+ $depth ||= 0;
+ $indent ||= 0;
if (not $tree ) {
return '';
my $cdr = $tree->[1];
if (ref $car) {
- return join ('', map $self->unparse($_, $bindargs, $depth), @$tree);
+ return join ('', map $self->unparse($_, $bindargs, $indent, $depth + 1), @$tree);
}
elsif ($car eq 'LITERAL') {
if ($cdr->[0] eq '?') {
elsif ($car eq 'PAREN') {
return '(' .
join(' ',
- map $self->unparse($_, $bindargs, $depth + 2), @{$cdr}) .
- ($self->_is_key($cdr)?( $self->newline||'' ).$self->indent($depth + 1):'') . ') ';
+ map $self->unparse($_, $bindargs, $indent + 2, $depth + 1), @{$cdr}) .
+ ($self->_is_key($cdr)?( $self->newline||'' ).$self->indent($indent + 1):'') . ') ';
}
elsif ($car eq 'OR' or $car eq 'AND' or (grep { $car =~ /^ $_ $/xi } @binary_op_keywords ) ) {
- return join (" $car ", map $self->unparse($_, $bindargs, $depth), @{$cdr});
+ return join (" $car ", map $self->unparse($_, $bindargs, $indent, $depth + 1), @{$cdr});
}
else {
- my ($l, $r) = @{$self->whitespace($car, $depth)};
- return sprintf "$l%s %s$r", $self->format_keyword($car), $self->unparse($cdr, $bindargs, $depth);
+ my ($l, $r) = @{$self->whitespace($car, $indent)};
+ return sprintf "$l%s %s$r%s", $self->format_keyword($car), $self->unparse($cdr, $bindargs, $indent, $depth + 1), $self->_caller_info($depth);
}
}