=head1 NAME

CFX5::Output - Functions for controllable text output

=head1 SYNOPSIS

Miscellaneous functions for text output, modelled around the functions
in cfx5deffn.

=cut

package CFX5::Output;
use strict;

use vars qw($CVSVersion);
$CVSVersion='$Id$ ';

use Exporter;
use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS);

@ISA=qw(Exporter);
@EXPORT_OK=qw(_abort _error _warn _note _info _trace _debug
              internal_error
              exit_if_error error_pending error_text reset_error_indicator
	      have_console have_stdout_file _print
	      add_output_object remove_output_object
              $Prog $LastError sim_print sim_info sim_warn sim_error
);

use CFX5::PkgLoader qw(cfx5_require);

=head2 Export tags

=over

=item :all

All functions.

=item :int

Internal output functions: C<_debug>, C<_trace>, C<internal_error>.

=back

=cut

%EXPORT_TAGS = (
    'all' => [qw(_abort _error _warn _note _info _trace _debug
               internal_error exit_if_error error_pending reset_error_indicator
	       add_output_object remove_output_object
	       have_console have_stdout_file _print sim_print sim_info sim_warn sim_error)],
    'int' => [qw(_debug _trace internal_error)],
    'obj' => [qw(add_output_object remove_output_object)],
);

=head3 $Prog

A variable, holding the basename of the file, without the C<.pl>
extension or the leading path name. It is initialised on module load.

=head3 $LastError

C<$LastError> stores the last error message printed, or is undefined
if no errors have yet been signalled. It can be used by other logging
functions to print a diagnostic message when the program exits.

=cut

use vars qw($LastError);
$LastError=undef;

use vars qw($Prog);
# get $Prog
$Prog=$0;
$Prog=~s{.*[/\\]}{}g;
$Prog=~s{ \.pl$ } {}x;

=head2 OUTPUT LIST HANDLING

Output from the various scripts is now handled by a list of handler
objects, each of types derived from L<CFX5::Output::Base>.  This
section includes a set of functions for handling this list. 

It is assumed that each registered object handles output either of a
different class of output or to a different destination, and so no
attempt is made to order the list of output objects.

=cut

use vars qw(%OutputList @FullFilterList);
@FullFilterList=qw(abort error warn info note trace debug print internal_error);

use vars qw($DefaultObject $DialogObject);

=head3 init_default_output

This routine should not be called directly by the user; it is used by
the C<init> function included below.  It sets up the output list with
a single object, which does the "standard" ANSYS CFX script output.

=cut

sub init_default_output {
  unless (defined $DefaultObject) {
    cfx5_require('CFX5::Output::Terminal');
    $DefaultObject = new CFX5::Output::Terminal();
  }

  # add it for all, it will sort itself out and ignore the ones it
  # isn't interested in.
  add_output_object($DefaultObject,undef);

  # and ensure that it is set up based on current settings, even if we
  # didn't create it this time.
  $DefaultObject->init();

  # don't use %CFX5::Config::Config, this would be the only use in this file
  if ($ENV{CFX5_SCRIPT_DEBUG_FILE}) {
    # switch this on to get output from different processes in
    # different files, if the onscreen output is too confusing.
    cfx5_require('CFX5::Output::File');
    my $myout=CFX5::Output::File->new("cfx5.$$.txt");
    $myout->set_output(':all' => 1);
    CFX5::Output::add_output_object($myout,undef);
  }
}

=head3 replace_default_output

  CFX5::Output::replace_default_output($new_out_obj);

Replaces the default output object with the supplied object.

=cut

sub replace_default_output {
  my $olddef=$DefaultObject;
  $DefaultObject=shift;

  add_output_object($DefaultObject)
    or _abort("Unable to add new default output object");
  remove_output_object($olddef)
    or _abort("Unable to remove previous default output object");

  return $olddef;
}


=head3 add_output_object

  my $myout=new CFX5::Output::Custom();
  CFX5::Output::add_output_object($myout,['debug','trace']);

Adds a given object to the list of objects which handle output (the
"output list").  The first parameter should be an object of a type
derived from C<CFX5::Output::Base>.  The second parameter can be
C<undef>, or an anonymous list reference.  If it is a list reference,
it is used as a filter, and only the named types of output will be
sent to that object.  (Note that some objects will implement their own
filtering, in which case you should pass C<undef> as the second
parameter).

Note that, as in the example above, the caller should keep a copy of
the object if she wishes to be able to manipulate it in the future,
for example to remove it from the list again!

=cut

sub add_output_object {
  my $obj=shift;
  my $filter=shift;
  my @filter=(defined $filter ? @$filter : @FullFilterList);

  unless ($obj->hook_add(@filter)) {
    return 0;
  }

  for my $f (@filter) {
    $OutputList{$f}={} unless exists $OutputList{$f};
    # this will store the object under a key which is a stringified
    # version of itself, thus ensuring that the same object is not
    # included twice in the same list.
    $OutputList{$f}{$obj} = $obj;
  }

  1;
}

=head3 remove_output_object

  CFX5::Output::remove_output_object($myout,undef);

Removes the given object from the output list.  As for
C<add_output_object>, the second parameter is a filter; if a list of
classes is specified, the object will be removed only from those
classes.  Usually, this parameter should be passed as C<undef> to
remove the object entirely.

=cut

sub remove_output_object {
  my $obj=shift;
  my $filter=shift;
  my @filter=(defined $filter ? @$filter : @FullFilterList);
  my $count;

  # no failure check, we're winding it up anyway
  $obj->hook_remove(@filter);

  for my $f (@filter) {
    next unless exists $OutputList{$f};
    $count++ if exists $OutputList{$f}{$obj};
    delete $OutputList{$f}{$obj};
  }

  $count;
}

=head2 OUTPUT ROUTINES

=head3 _abort, _error, _warn, _note, _info, _trace, _debug

These functions behave (almost ;-) exactly like those in C<cfx5deffn>.

Note that the _ prefix has been kept here to avoid clashes with
builtin functions.

=cut

{
  my %Recur;
sub do_output_olist {
  my $call=shift;
  my $rv=1;

  # initialise if necessary
  init();

  # because we always register the default object for everything, this
  # is a good check to make of whether this is a sensible parameter
  unless (exists $OutputList{$call}) {
    # recursion-protect!
    if ($call eq 'internal_error') {
      die "Internal error: no output objects are registered to handle internal\nerror: ", join(' ',@_), "\n";
    } else {
      internal_error("No output objects are registered to handle $call");
    }
  }

  if ($Recur{$call}) {
    # skip debugs inside debugs etc
    return;
  }
  local $Recur{$call}=1;

  my @objects=values %{$OutputList{$call}};
  for my $o (@objects) {
    $call=~s!^sim!!g;
    if ($o->can($call)) {
      eval {
        $o->$call(@_) or $rv=0;
      };
      # I can't figure out why, but for some reason, some of the file
      # output calls end up dieing.
      if ($@) {
        _warn("Output call terminated unexpectedly: $@");
      }
    } else {
      if ($call eq 'internal_error') {
        die "Internal error: $o is unable to handle internal error: ", join(' ',@_), "\n";
      } else {
        internal_error("Object $o cannot handle $call");
      }
    }
  }
  $rv;
}
}

# return TRUE if we're currently somewhere inside a BEGIN block, FALSE
# otherwise.
sub is_startup {
  my $i=0;
  while (defined caller($i)) {
    return 1 if (caller($i))[3] =~ m!BEGIN$!;
    $i++;
  }
  0;
}

sub _abort {
  my $Err=join(" ",@_);
  $LastError=$Err;
  do_output_olist('abort', $Err);
  if (is_startup()) {
    # if we're in a begin block, we exit with a successful return
    # code, to avoid nasty "callback called exit" messages from Perl.
    # Not ideal, but better than nothing.
    exit();
  } else {
    exit(2);
  }
}

sub sim_error {
  my $Err=join(" ",@_);
  $LastError=$Err;
  do_output_olist('simerror', join(" ",@_));
}

sub _error {
  my $Err=join(" ",@_);
  $LastError=$Err;
  do_output_olist('error', join(" ",@_));
}

sub sim_warn {
  do_output_olist('simwarn', join(" ",@_));
}

sub _warn {
  do_output_olist('warn', join(" ",@_));
}

sub sim_note {
  do_output_olist('simnote', join(" ",@_));
}

sub _note {
  do_output_olist('note', join(" ",@_));
}

sub sim_info {
  do_output_olist('siminfo', join(" ",@_));
}

sub _info {
  do_output_olist('info', join(" ",@_));
}

sub _debug {
  do_output_olist('debug', join(" ",@_));
}

sub _trace {
  do_output_olist('trace', join(" ",@_));
}

=head3 _print

Acts like a normal Perl C<print> to stdout, but if there is no
console, sends the output to the logfile (if there is one)
instead. See C<detach_from_console>.

This function should usually be used instead of C<print> to display
large chunks of information to the user; it is like _info but not
switch-off-able.  (Although, if the software is running without a
console, it may get lost ...)

=cut

sub sim_print {
  do_output_olist('simprint', join('',@_));
}

sub _print {
  do_output_olist('print', join('',@_));
}

=head3 internal_error

Signal an internal error and abort, showing a stack traceback from the
POV of the caller (using the same function as cluck/confess in
L<Carp>), and abort. This should be used for conditions which are not
expected to happen to ordinary users.

=cut

sub internal_error {
  my $Err=join(" ",@_);
  $LastError="INTERNAL: $Err";
  do_output_olist('internal_error', join(" ",@_));
  die "Aborting due to internal error: \"$Err\".\n";
}

=head2 STATUS INTERROGATION

=head3 exit_if_error

If we've encountered an error (via C<_error>), exit the
program. Otherwise do nothing.

=cut '

sub exit_if_error {
  return unless defined $LastError;
  _debug "Exiting due to error $LastError";
  exit(2);
}

=head3 error_pending

If we've encountered an error (via C<_error>), return TRUE; otherwise return FALSE.

=cut '

sub error_pending {
  return defined $LastError;
}

=head3 error_text

If we've encountered an error (via C<_error>), return the error text
of the most recent one; otherwise return undef.

This function should not normally be used, it is designed for use in
regression testing.

=cut '

sub error_text {
  return $LastError;
}

=head3 reset_error_indicator

  reset_error_indicator();

Pretends nothing has gone wrong.  This is mostly for debugging stuff.
It returns the last error to be displayed.

=cut

sub reset_error_indicator {
  my $err=$LastError;
  undef $LastError;
  $err;
}

=head2 VERBOSITY CONTROL

=head3 set_verbosity

Sets the level of output.  See the C<set_verbosity> method on the
L<CFX5::Output::Terminal> object for more details.

=cut

sub set_verbosity {
  $DefaultObject->set_verbosity(@_);
}

=head3 query_verbosity

Queries the level of output.  See the C<query_verbosity> method on the
L<CFX5::Output::Terminal> object for more details.

=cut

sub query_verbosity {
  $DefaultObject->query_verbosity(@_);
}

=head2 CONSOLE HANDLING

=head3 detach_from_console

This function currently does nothing on UNIX systems.

  CFX5::Output::detach_from_console();

This function has a whole set of different effects. Firstly, it
detaches the current process from its active console, so if the
console was started just for this process it will disappear. This is
useful if programs are run from a GUI, when having a console isn't
necessarily relevant.

Secondly, it changes the functions below so that they put messages up
in dialog boxes, or other places which work better with a console-less
program. In particular, output (such as that from C<_info>) which
would normally be sent to C<stdout> goes to a log file
F<scriptname.log> (or the bit bucket if that file could not be opened;
this is important on NT!), and output (such as that from C<_abort>)
which would normally go to C<stderr> will be popped up in a dialog
box.

Note that this does not cause the command prompt to return on the
console you are detaching from.

=cut '

use vars qw($HaveConsole $StdOutFD);
$HaveConsole=1;
$StdOutFD = undef;

sub my_die {
  internal_error("Perl die()");
}

sub my_warn {
  _debug(@_);
}

sub detach_from_console {
  return unless $HaveConsole;
  return unless $^O eq "MSWin32";

  cfx5_require('CFX5::Win32::Output');

  cfx5_require('CFX5::Output::Win32Dialog');

  unless (defined $DialogObject) {
    $DialogObject=new CFX5::Output::Win32Dialog();
  }
  add_output_object($DialogObject,undef);

  # open a FD for the logs if possible. If we succeed, we assign a
  # reference to the handle to a variable; if we fail, $StdOutFD stays
  # as undef, and we'll check for that later.
  local *STDOUTFILE;
  if ($ENV{CFX5_SAVE_OUTPUT_NOCONSOLE}
      and open(STDOUTFILE, ">$Prog.log")) {
    $StdOutFD = *STDOUTFILE{IO};
    # unbuffer STDOUTFILE from perlfaq5
    select((select(STDOUTFILE), $| = 1)[0]);

    # see if we can replace STDOUT and STDERR globally
    open STDOUT, '>&STDOUTFILE';
    open STDERR, '>&STDOUTFILE';
  }

  # override some Perl stuff. We don't override print, as that can
  # also take a filehandle, but we do rely on people being sensible
  # ... 
  *CORE::global::die  = \&my_die;

  *CORE::global::warn = \&my_warn;

  # mark the console as hidden, now we're set up to handle this
  $HaveConsole=0;

  # finally, we should be able to hide the console. But first, give a
  # descriptive message, in case somebody else is also attached to it.
  #
  # No, we don't, as it might make people try to read the message when
  # they shouldn't be bothering. :-(

  #print 'ANSYS CFX detaching from console.',"\n";
  #print "Output will be sent to $Prog.log\n"
  #  if defined $StdOutFD;

  unless ($ENV{dont_really_detach} or CFX5::Win32::Output::hide_console()) {
    _trace("Unable to detach from console: error hiding console");
    return 0;
  }

  1;
}

=head3 have_console

  if (have_console()) {
    # ...
  }

Returns TRUE if there is a console attached (always on UNIX), or FALSE
otherwise.

=cut

sub have_console { $HaveConsole; }

=head3 have_stdout_file

Returns TRUE if we managed to open a file on stdout, or FALSE
otherwise. The return value is undefined unless C<have_console> is
FALSE. 

=cut

sub have_stdout_file { defined $StdOutFD; }

=head2 SETUP AND INITIALISATION

=head3 init

Misc initialisation stuff

The following C<init> routine block prints the script, version and
argument list, assuming the arguments are not modified before this
module is C<use>d.

It also initialises the output level from the CFX_OUTPUT variable, and
displays (if tracing) some information about the current program.

=cut

{
  my $init=0;
sub init {
  return if $init++;

  # make sure whatever we have is consistent with the current
  # CFX_OUTPUT settings.
  init_default_output();

  # First thing we do is to check whether or not we're running without
  # a console.  We don't remove the -NoConsole argument, because the
  # wrapper needs to pass it on, but it's ignored later when the
  # arguments are parsed.
  my $noconsole=0;
  for my $sw (@main::ARGV) {
    $noconsole++ if $sw eq '-NoConsole';
  }
  if ($noconsole) {
    detach_from_console();
  }

  # display some info if we're tracing
  _trace $main::CVSVersion if defined $main::CVSVersion;
  _trace $$, $0, @ARGV;

  ++$init;
}

sub is_init {
  return $init >= 2;
}

}

1;
