=head1 NAME

CFX5::Output::Base - abstract class for output objects

=head1 SYNOPSIS

  package CFX5::Output::NewFangled;
  @ISA=qw(CFX5::Output::Base);
  use strict;

  sub output {
    # not really practical usage here ...
    SomeDialogBoxRoutine(@_);
  }

=head1 DESCRIPTION

This module is an abstract base class for the objects used by
L<CFX5::Output> to make different output styles possible.  See
L<CFX5::Output::Terminal> for a sample implementation.

=cut

package CFX5::Output::Base;

use strict;
use Carp;

use CFX5::Output::Utils 'wraptext';

=head2 CONCRETE METHODS

=head3 new

  package CFX5::Output::MyNewStyle;
  sub init { $_[0]->SUPER::init(); }

  package main;
  my $output=new CFX5::Output::MyNewStyle();

This is a standard overloadable constructor.  It will create and
initialise an anonymous hash, blessed into the correct package, and
then call its C<init> routine with any arguments which were passed.
The overloaded C<init> routine should call back to the C<init> routine
from the parent class, which takes no arguments.  If the init routine
gives a FALSE exit code, the constructor will return undef; otherwise,
it will return the newly-initialised object.

=cut

sub new {
  my $this=shift;
  my $class=ref($this) || $this;
  my $self={};
  bless $self, $class;
  $self->init(@_) or return undef;
  $self;
}

=head3 init

(Called by C<new>, this should not be called directly)

The default init routine currently does nothing, successfully.

=cut

sub init {
  1;
}

=head3 set_output

  $file->set_output(':all' => 1);
  $file->set_output(info => 1, error => 0);

Sets the output level for individual levels, or for the entire set.

=cut

sub set_output {
  my $self=shift;
  while (@_) {
    my $key=shift;
    my $val=shift;
    if ($key eq ':all') {
      for my $k (keys %{$self->{settings}}) {
        $self->{settings}{$k} = $val
          unless $k eq 'stack';
      }
    } else {
      if (exists $self->{settings}{$key}) {
        $self->{settings}{$key} = $val;
      } else {
        _error("Bad output setting key $key");
      }
    }
  }
}

=head3 have_output

  if ($file->have_output('trace')) {
    ...
  }

Returns TRUE if this object will produce the named type of output, or
FALSE if not.

=cut

sub have_output {
  my $self=shift;
  my $k=shift;
  return $self->{settings}{$k};
}

=head2 PURE VIRTUAL METHODS

These methods are not implemented in the base class, and must be
supplied by any subclass (at least, any which wants to use them; see
the comments against the individual functions).

=head3 output

  package CFX5::Output::Custom;
  sub output {
    my $self=shift;
    my $type=shift;
    my $severity=shift;
    my $title=shift;
    my $text=join('',@_);

    # do something
  }


  package main;
  $oo->output($type,$severity,$title,$text);

This is the routine which actually does the output!  The arguments are
as follows:

=over

=item C<$type>

The type of output to do.  This corresponds to the routine from
L<CFX5::Output> which originated the message, and will be one value
from this list:

=over

=item C<abort>

=item C<error>

=item C<warn>

=item C<info>

From either C<_note> or C<_info>

=item C<trace>

=item C<debug>

=item C<print>

From C<_print>.  This is not an optional call, but may be ignored by
some objects.

=item C<internal>

=back

=item C<$severity>

The severity can be used for dialog boxes and so on.  This is a word
from the following list:

=over

=item C<"fatal">

=item C<"error">

=item C<"warn">

=item C<"info">

=item C<"debug">

=back

=item C<$title>

This will be a short description of the type of error, used as the
title for a dialog box or the introduction to an error message.  For
example, C<"An error has occurred in cfx5build.pl (12345)">.  Some
calls, for example C<info>, pass C<undef> in this parameter to
suppress the title.

=item C<$text>

The text of the message.

=item C<$optional>

More information.  For example, the stack trace from an internal error
is passed this way.

=back

This routine is used only by the other default methods in
C<CFX5::Output::Base>, and is never called externally.  Thus, if all
the output methods described below are overridden, this method need
not be supplied, although politeness suggests that the message should
be changed!

=cut

sub output {
  if (ref($_[0]) eq 'CFX5::Output::Base') {
    croak(ref($_[0])." objects may not be instantiated directly!");
  } else {
    croak("The output function must be overridden in classes derived from CFX5::Output::Base");
  }
}

=head3 text_to_show

  sub output {
    # ...
    print $self->text_to_show($title,$text);
  }

This utility method takes the C<$title> and C<$text> arguments from
C<output>, and handles the standard forms of line-wrapping etc.  Word
wrapping is done to the value of the configuration record
C<CFX5_TERMINAL_WIDTH>, or 75 by default; verbatim lines (such as
filenames) are not wrapped.

=cut

sub text_to_show {
  my $self=shift;
  my $title=shift;
  my $text=join('',@_);

  my $width=$self->wrapwidth();

  my $out='';

  $out .= $title . "\n\n" if defined $title;

  $out .= $text;
  $out .= "\n\n" . $self->stack_trace() if $self->{settings}{stack};
  $out=wraptext(-$width, $out);

  # how many CRs did we have after $text, originally?  If there were
  # multiple ones there to start with, we must preserve them.
  my $tcr=defined $title ? "\n" : "";
  if ($text =~ m!(\n+)\n$!) {
    $tcr=$1;
  }

  $out .= $tcr;

  # how about before the text?  This only matters if we have no title.
  unless (defined $title) {
    if ($text =~ m!^(\n+)!) {
      $out = $1 . $out;
    }
  }

  $out;
}

=head3 wrapwidth

Returns the width to wrap output to.  May be overridden by subclasses.

=cut

sub wrapwidth {
  my $self=shift;

  if (defined $self->{__PACKAGE__ . '::wrapwidth'}) {
    return $self->{__PACKAGE__ . '::wrapwidth'};
  }

  my $width;
  if (defined &CFX5::Config::getconf) {
    $width=CFX5::Config::getconf('CFX5_TERMINAL_WIDTH');
  } else {
    $width=$ENV{CFX5_TERMINAL_WIDTH};
  }
  $width || 75;
}

=head3 set_wrapwidth

  $obj->set_wrapwidth(120);

Allows the user to specify the width to wrap to directly.  This
overrides the wrapwidth call in this class, but may not affect
reimplementations in subclasses.

=cut

sub set_wrapwidth {
  my $self=shift;
  my $wid=shift;
  $self->{__PACKAGE__ . '::wrapwidth'} = $wid;
}

=head2 OUTPUT METHODS

These methods have a default version in L<CFX5::Output::Base>, but may
be overridden if desired.  These are the functions which are called
when the output functions from L<CFX5::Output> are called, and take
the same argument lists.  The default implementations simply call the
C<output> method with the relevant argument lists.

=head3 abort

Note that this routine must not exit, that is handled by the caller.

=cut

sub abort {
  my $self=shift;
  my $title="A fatal error has occurred in ".$self->progname();

  if ($self->{settings}{debug} or $self->{settings}{trace}) {
    my $summ=$self->caller_sum();
    if (defined $summ) {
      $title .= " in $summ";
    }
  }

  my @xtra;
  if ($self->{settings}{debug}) {
    push @xtra,
      "\n\nThe following information may be useful to CFX support staff:\n"
        . $self->stack_trace();
  }

  $self->output('abort','fatal',
		"$title:",
		join(' ',@_, @xtra));
}

=head3 error

=cut

sub error {
  my $self=shift;
  my $title="An error has occurred in ".$self->progname();

  if ($self->{settings}{debug} or $self->{settings}{trace}) {
    my $summ=$self->caller_sum();
    if (defined $summ) {
      $title .= " in $summ";
    }
  }

  my @xtra;
  if ($self->{settings}{debug}) {
    push @xtra,
      "\n\nThe following information may be useful to CFX support staff:\n"
        . $self->stack_trace();
  }

  $self->output('error','error',
		"$title:",
		join(' ',@_, @xtra));
}

=head3 warn

=cut

sub warn {
  my $self=shift;
  $self->output('warn','warn',
		'Warning!',
		join(' ',@_));
}

=head3 note

=cut

sub note {
  my $self=shift;
  $self->output('info','info',
		'Please note:',
		join(' ',@_));
}

=head3 info

C<info> is like C<note>, but does not include a header when sent to
the terminal.  This is an obvious candidate for overriding in other
modules!  In the default implementation, this is signified by passing
C<undef> as the title.

=cut

sub info {
  my $self=shift;
  $self->output('info','info',
		undef,
		join(' ',@_)."\n");
}

=head3 trace

This outputs a trace message.  Again, by default, the title is
suppressed by passing C<undef>.  The message string is passed through,
prefixed with a process ID.

=cut

sub trace {
  my $self=shift;
  my @times=times();
  my $time=sprintf("%0.3g", $times[0] + $times[1]);
  $self->output('trace','trace',
		undef,
		join(' ',"TRACE\[".$self->progname().":$time\]>",@_)."\n");
}

=head3 debug

This outputs a debugging message.  Again, by default, the title is
suppressed by passing C<undef>.  The message string is passed through,
prefixed with the name of the routine generating the debugging
message, and its caller.  See C<call_level>.

=cut

sub debug {
  my $self=shift;
  my $summ=$self->caller_sum();
  if (defined $self->{__PACKAGE__.'::summ'} and $summ eq $self->{__PACKAGE__.'::summ'}) {
    $summ='';
  } else {
    $self->{__PACKAGE__.'::summ'}=$summ;
  }
  $self->output('debug','debug',
		undef,
		join(' ',"DEBUG\[".$summ."\]>",@_)."\n");
}

=head3 print

This is a message to stdout, just like the Perl C<print> call, but it
will go through the chain of objects.

=cut

sub print {
  my $self=shift;
  $self->output('print','info',
		undef,
		join(' ',@_));
}

=head3 message

This is a non-optional but informational message to stdout, rather
like C<note> but does not only happen in verbose mode.

=cut

sub message {
  my $self=shift;
  $self->output('print','info',
		'',
		join(' ',@_));
}

=head3 internal_error

This method is used to signal an internal error in another part of the
code.  The default implementation will send the error text, along with
a stack trace, on to the C<output> method.

As for C<abort>, this method should not explicitly exit, as this is
the responisbility of the caller (since there may be more than one
registered handler for this type of error).

=cut

sub internal_error {
  my $self=shift;

  $self->output('internal','fatal',
		"An internal error has been detected in ".$self->progname(),
		join(' ',@_),
		"\n\nThe following information may be useful to CFX support staff:\n"
		. $self->stack_trace());
}

=head2 HELPER METHODS

These methods are called by the above output methods, and may also be
used by subclasses.  They should probably not be called directly from
other places.

=head3 progname

Returns a string naming the program, for use in error messages.  This
is derived from the C<$0> variable.

=cut

use vars qw($ProgramName);
($ProgramName=$0) =~ s!.*[\\/]!!g;
$ProgramName =~ s!\.pl$!!;

sub progname { $ProgramName; }

=head3 caller_sum

  $self->show("DEBUG".$self->caller_sum(), @_);

Returns a string giving some information about the caller of the
outermost output routine (see C<call_level>).  By default, this is the
name of the routine and of its caller.  This is used by the standard
C<debug> method.

=cut

sub caller_sum {
  my $self=shift;
  my $lvl=$self->call_level() + 1;
  my $rv;
  if (my @first=caller($lvl)) {
    if (defined $first[3]) {
      $rv .= $first[3];
    } else {
      $rv .= '?()';
    }
  } else {
    $rv .= 'main program';
  }
  if (my @parent=caller($lvl+1)) {
    if (defined $parent[3]) {
      $rv .= '('.$parent[3].')';
    }
  }
  $rv;
}

=head3 call_level

This routine is provided by C<CFX5::Output::Base> to allow
encapsulation of the determination of the level in the stack from
which we were called.  Its return value is a number such that

  caller($self->call_level())

will return the stack frame from the routine which executed the
original output instruction, I<when called from the first routine from
this object which is callable>.  Authors of derived objects may wish
to modify this, but should probably start from this implentation
rather than writing it again from scratch, as this version knows about
the internal implementation in L<CFX5::Output>.

=cut

sub call_level() {
  4;
}

=head3 stack_trace

  my $trace=$self->stack_trace('Internal error');

This is the routine which generates the stack trace, as reported by
C<internal_error>.  It takes one argument, which is the prefix string
to use; if this is not specified, it defaults to 'Currently'.

=cut

sub stack_trace {
  my $self=shift;
  my $prefix=shift;
  $prefix='Currently' unless defined $prefix;

  local $Carp::CarpLevel = call_level();

  "\t".$prefix.Carp::longmess();
}

=head2 HOOK METHODS

These methods are called at various times in the life cycle of an
object, and are designed to allow the programmer to intercept various
actions involving the object.  The C<CFX5::Output::Base> object
provides dummy versions of these routines which simply return success.
See also C<init>.

=head3 hook_add

  sub hook_add {
    $self->SUPER::hook_add();
    $self->ensure_log_is_open() or return 0;
    1;
  }

This routine is called when the object is added to the list of handler
objects.  It can be used to ensure that everything is ready for the
logging to take place.  If it returns FALSE, the handler object is not
added to the list (but no error is signalled by L<CFX5::Output>).

=cut

sub hook_add { 1; }

=head3 hook_remove

  sub hook_remove {
    $self->close_log();
    $self->SUPER::hook_remove();
  }

This routine is called when the object is removed from the list of
handler objects.  It can be used to ensure that all data is
successfully written, and files etc are closed.

Note that, if the object is not explicitly removed by the programmer,
this routine may not be called on program exit unless (s)he registers
a DESTROY handler.

=cut

sub hook_remove { 1; }

1;
