package PSP::Utils;

# Copyright (c) 2000, FundsXpress Financial Network, Inc.
# This library is free software released under the GNU Lesser General
# Public License, Version 2.1.  Please read the important licensing and
# disclaimer information included below.

# $Id: Utils.pm,v 1.1.1.2 2003/12/06 19:47:26 hartmans Exp $

use strict;
$PSP::VERSION = '0.505';

=head1 NAME

 PSP::PileUtils - Subroutines for PSP compiler and piles.

=head1 SYNOPSIS

 #more to come

=head1 DESCRIPTION

A set of utilities useful in a pile.  more to come.

=cut

use Exporter;
use Data::Dumper;

@PSP::Utils::ISA = qw(Exporter);
@PSP::Utils::EXPORT =
  qw(
     path_to_page_name
     page_name_to_path
     reduce_url
     dir_change stack_trace
     psp_stack_trace
     bool_att
     backtrace
     quote_bareword
     dump_object
     save_or_restore_env
    );

=head1 METHODS

=head2 path_to_page_name

=cut

sub path_to_page_name {
  my ($page_name) = @_;

  # don't do anything if page_name is already in page_name form.
  return $page_name if $page_name !~ m!/! and $page_name =~ m!__!;

  # get rid of any leading /'s and .'s
  $page_name =~ s:^[\./]+::o;
  # convert url separators to page_name separators.
  $page_name =~ s:/+:__:og;
  # get rid of any unwanted extensions.
  $page_name =~ s:\.(psp|htm|html)$::oi;
  # convert special path "_" to blank page_name.
  $page_name = "" if $page_name eq "_";
  # convert any remaining .'s and -'s to _'s.
  $page_name =~ s:[\.\-]:_:og;
  # perpend "page__"
  $page_name =~ s/^(page__)?/page__/;

  return $page_name;
}

sub page_name_to_path {
  my ($path) = @_;

  # don't do anything if the path is already in path form.
  return $path if $path =~ m!\/! and $path !~ /__/;

  # get rid of any leading "page__".
  $path =~ s!^(page__)!!g;
  # convert page_name separators to url separators.
  $path =~ s!__!/!g;

  return $path;
}

sub reduce_url {
  my ($url) = @_;
  # remove "."s
  $url =~ s!/\./!/!g;
  # resolve ".."s
  while ($url =~ s!/[^/\.]+/\.\./!/!) { }
  # remove remaining ".."s
  $url =~ s!\.\.+!!g;
  # collapse multiple url separators.
  $url =~ s!//+!/!g;
  return $url;
}

=head2 dir_change

 [private] package
 (bool $changed) dir_change (string $page1, string $page2)

DESCRIPTION:

Checks C<$page1> against C<$page2> and determines if there has been a
directory change or not. The format of the pages may be either
functional or HTML off the PSP-root.

=cut

sub dir_change {
  my ($check, $against) = @_;
  $check   =~ s/(::)?[\w\d_]+$//;
  $against =~ s/(::)?[\w\d_]+$//;
  $check   =~ s+^(\.?/|::)++;
  $against =~ s+^(\.?/|::)++;
  $check   =~ s|/|::|g;
  $against =~ s|/|::|g;
  return $check ne $against;
}

sub psp_stack_trace {
  my $n = 1;
  my $out = "";
  while (my @caller = caller($n++)) {
    $out .= "$caller[3]\n";
  }
  $out;
}

sub bool_att {
  my ($value,$default) = @_;
  if (defined $value) {
    if ($value eq "false") {
      return 0;
    } else {
      return $value ? 1 : 0;
    }
  } else {
    return $default;
  }
}

=head2 add_dticks

 [private] package
 (string $ticked) add_dticks (string $string)

DESCRIPTION:

Will add tick quotes to C<$string> and return it. Will attempt to do
so safely in that it will make no change if there are already
quotes. If there are no quotes, then tick quotes will be added.

We may want to change this to handle double quotes in a clearer
manner.

=cut

sub add_dticks {
  my $field_name = shift;
  return $field_name if $field_name =~ /^".*"$/;
  return $field_name if $field_name =~ /^'.*'$/;
  $field_name =~ s/([^\\])"/\\"/g;
  return '"'.$field_name.'"';
}

=head2 add_ticks

 [private] package
 (string $ticked) add_ticks (string $string)

DESCRIPTION:

Will add tick quotes to C<$string> and return it. Will attempt to do
so safely in that it will make no change if there are already
quotes. If there are no quotes, then tick quotes will be added.

We may want to change this to handle double quotes in a clearer
manner.

=cut

sub add_ticks {
  my $field_name = shift;
  unless ($field_name =~ /[\',\"][\w]/) {
    $field_name = "'".$field_name;
    unless ($field_name =~ /\'$/) {
      if ($field_name =~ /\"$/) {
	$field_name =~ s/\"$/\'/;
      }
      else {
	$field_name = $field_name."'";
      }
    }
  }
}

sub quote_bareword {
  my ($text) = @_;
  defined $text or return "undef";

  # leave unquoted if it matches obj/method, or is already quoted.
  #
  if ($text =~ /^\s*\$\w+(\s*->\s*[\[\]{}\(\)\w]+)*\s*$/ or 
      $text =~ /^([\"\']).*\1$/ ) {
    return $text;
  }

  # do the quoting.
  #
  $text =~ s/([^\\])"/\\"/g;
  return '"'.$text.'"';
}

sub backtrace {
  my $out = "";

  my $i = 1;
  my @caller;
  do {
    @caller = caller($i);
    @caller and $out .= "$i: $caller[0]:$caller[2] -- $caller[3]\n";
    $i++;
  } while (@caller);
  $out;
}

sub dump_object {
  my ($obj,$name,$exclude) = @_;
  $name ||= '$Object';
  $exclude ||= [];

  # remove certain fields.
  my %keep;
  for (@$exclude) {
    $obj->{$_} or next;
    $keep{$_} = $obj->{$_};
    $obj->{$_} = "\$\u$_";
  }

  # dump to string.
  my $str = Dumper($obj);

  # replace those certain fields.
  map { $obj->{$_} = $keep{$_} } keys %keep;

  # edit the variable name of this dump.
  if ($str =~ /^\$(\w+)\b/) {
    my $var = $1;
    $str =~ s/\$$var\b/$name/g;
  }

  # edit leading whitespace.
  my $out_str = "";
  for my $line (split /\n/,$str) {
    my $space;
    $line =~ s/         //;
    $line =~ s/^(\s+)// and $space = ' ' x int(length($1)/8);
    $out_str .= $space.$line."\n";
  }

  return $out_str;
}

=head2

 global
 () save_or_restore_env (string $filename)

DESCRIPTION:

When called in a web service context, it should dump the current
environment to the specified file.

When called in a command-line context, the environment should be restored.

=cut

use vars qw($already_warned_write_env);
sub save_or_restore_env {
  my ($fname) = @_;

  if (! $ENV{SERVER_PROTOCOL} and -f $fname) {
    print "+++++++++++++++++++++++++++++++++++++++++++++++++\n";
    print "Detected previous environment in $fname\n";
    print "+++++++++++++++++++++++++++++++++++++++++++++++++\n";
    if (open FILE, $fname) {
      my $text = join("",<FILE>);
      close FILE;
      my $ENV;
      eval $text;
      %ENV = %$ENV;
    }
  } else {
    if (! $already_warned_write_env++) {
      warn("Writing environment to $fname for this session\n");
    }
    use Data::Dumper;
    if (open FILE, ">".$fname) {
      print FILE Data::Dumper->Dump([\%ENV],['ENV']);
      close FILE;
    }
  }
}

1;
__END__

=head1 BUGS

No known bugs, but this does not mean no bugs exist.

=head1 SEE ALSO

L<Data::Dumper>

=head1 COPYRIGHT

 PSP - Perl Server Pages
 Copyright (c) 2000, FundsXpress Financial Network, Inc.

 This library is free software; you can redistribute it and/or
 modify it under the terms of the GNU Lesser General Public
 License as published by the Free Software Foundation; either
 version 2 of the License, or (at your option) any later version.

 BECAUSE THIS LIBRARY IS LICENSED FREE OF CHARGE, THIS LIBRARY IS
 BEING PROVIDED "AS IS WITH ALL FAULTS," WITHOUT ANY WARRANTIES
 OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, WITHOUT
 LIMITATION, ANY IMPLIED WARRANTIES OF TITLE, NONINFRINGEMENT,
 MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE, AND THE
 ENTIRE RISK AS TO SATISFACTORY QUALITY, PERFORMANCE, ACCURACY,
 AND EFFORT IS WITH THE YOU.  See the GNU Lesser General Public
 License for more details.

 You should have received a copy of the GNU Lesser General Public
 License along with this library; if not, write to the Free Software
 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA

=cut