#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2014 -- leonerd@leonerd.org.uk

package Tickit::Debug;

use strict;
use warnings;
use 5.010; # //

# Behaviour depends on some environment variables
use constant DEBUG_FLAGS => { map { +$_ => 1 } split m/,/, $ENV{TICKIT_DEBUG_FLAGS} // "" };
use constant DEBUG => scalar keys %{+DEBUG_FLAGS};

use Exporter 'import';
our @EXPORT = qw( DEBUG );

use Time::HiRes qw( gettimeofday );
use POSIX qw( strftime );

our $debug_fh;

=head1 NAME

C<Tickit::Debug> - debug logging support for C<Tickit>

=head1 DESCRIPTION

This module implements the debug logging logic for L<Tickit>. It is controlled
by a number of environment variables. It exports a constant called C<DEBUG>
which will be true if the debug logging is enabled; allowing code to
efficiently skip over it if it isn't.

Debug messages themselves each have a flag name, which is a short string
identifying the Tickit subsystem or kind of event that caused it. A given
subset of these flags can be enabled for printing. Flags not enabled will not
be printed.

=cut

=head1 FLAGS

Each flag name starts with a upper-case letters indiciating the subsystem it
relates to, then lower-case letters to indicate the particular kind of event
or message.

=head2 B (RenderBuffer)

=head3 Bd

Drawing operations

=head3 Bf

Flushing

=head3 Bs

State stack save/restore

=head3 Bt

Transformations (translate, clip, mask)

=head2 I (Input)

=head3 Ik

Keyboard events

=head3 Im

Mouse events

=head3 Ir

Resize events

=head2 W (Window)

=head3 Wd

Rectangles of damage queued on the root window for re-expose

=head3 Wh

Heirarchy changes on Windows (creates, deletes, re-orderings)

=head3 Ws

Calls to C<< $win->scrollrect >>

=head3 Wsr

Calls to C<< $term->scrollrect >> on the root window as part of scrollrect

=head3 Wx

Expose events on Windows; which may result in calls to its C<on_expose>
handler. As this event is recursive, it prints an indent.

=cut

=head1 ENVIRONMENT

=head2 TICKIT_DEBUG_FLAGS

A comma-separated list of the flags or flag categories to enable for printing.
Each potential flag exists in a category, given by the leading upper-case
letters of its name. Entire categories can be enabled by name, as can
individual flags.

See the L</FLAGS> list above for the available flags.

=head2 TICKIT_DEBUG_FD

If set, debug logging is sent directly to the opened filehandle given by this
file descriptor number, rather than opening a log file.

Typically this is most useful to start a C<Tickit>-based application in a new
terminal but have its debug logging printed to STDERR of the original terminal
the new one was launched from. For example

 $ TICKIT_DEBUG_FD=3 TICKIT_DEBUG_FLAGS=... $TERM perl my-tickit-app.pl 3>&2

This requests that C<Tickit::Debug> log to file descriptor 3, which has been
created by copying the original shell's standard error output, and so logging
is printed to the shell this was run from.

=head2 TICKIT_DEBUG_FILE

Gives the name of a file to open and write logging to, if C<TICKIT_DEBUG_FD>
is not set. If this is not set either, a filename will be generated using the
PID of the process, named as

 tickit-PID.log

=cut

if( DEBUG ) {
   if( $ENV{TICKIT_DEBUG_FD} ) {
      require IO::Handle;

      $debug_fh = IO::Handle->new;
      $debug_fh->fdopen( $ENV{TICKIT_DEBUG_FD}, "w" ) or
         undef $debug_fh;
   }
   else {
      open $debug_fh, ">", $ENV{TICKIT_DEBUG_FILE} // "tickit-$$.log"
         or warn("Unable to open Tickit debug logging file - $!; logging disabled\n");
   }

   if( $debug_fh ) {
      $debug_fh->autoflush(1);

      $debug_fh->printf( "Logging started\n" );
   }
}

=head1 METHODS

=cut

=head2 Tickit::Debug->log( $flag => $format, @args )

Prints a line to the debug log if the specified C<$flag> is present in the set
of enabled flags.

Any arguments that are C<CODE> references are called and replaced by the
list of values they return, then the line itself is generated by calling
C<sprintf> using the format string and the given arguments. It is then
printed to the log, prefixed by the flag name and with a linefeed appended.

It is not necessary to include the C<\n> linefeed in the C<$format> itself.

=cut

sub log :method
{
   shift;
   my ( $flag, $format, @args ) = @_;

   return unless $debug_fh;

   $flag =~ m/^([A-Z]+)/;
   my $flag_category = $1;

   return unless DEBUG_FLAGS->{$flag} ||
      ( $flag_category && DEBUG_FLAGS->{$flag_category} ) ||
      DEBUG_FLAGS->{"*"};

   my $message = sprintf $format, map { ref eq "CODE" ? $_->() : $_ } @args;

   my ( $sec, $usec ) = gettimeofday;
   my $timestamp = strftime( "%H:%M:%S", localtime $sec );

   $debug_fh->printf( "%s.%03d [%-3s]: %s\n", $timestamp, $usec / 1000, $flag, $message );
}

=head1 AUTHOR

Paul Evans <leonerd@leonerd.org.uk>

=cut

0x55AA;
