File Coverage

lib/Termbox.pm

Criterion	Covered	Total	%
statement	45	45	100.0
branch			n/a
condition			n/a
subroutine	15	15	100.0
pod			n/a
total	60	60	100.0

package Termbox {
    use 5.020;
    use strict;
    use warnings;
    our $VERSION = "2.01";
    #
    use File::ShareDir        qw[dist_dir];
    use File::Spec::Functions qw[catdir canonpath];
    #
    use FFI::CheckLib;
    use FFI::Platypus 2;
    use FFI::Platypus::Memory qw( malloc free );
    $ENV{FFI_PLATYPUS_DLERROR} = 1;
    my $ffi = FFI::Platypus->new(
        api  => 1,
        lang => 'C',
        lib  => find_lib_or_exit(
            lib       => 'termbox2',
            recursive => 1,
            libpath   => [ qw[ . ./share/lib], canonpath( catdir( dist_dir(__PACKAGE__), 'lib' ) ) ]
        )
    );
    #
    use base qw[Exporter];
    use vars qw[@EXPORT_OK @EXPORT %EXPORT_TAGS];

    # Utility functions that should be at the end but we need it here
    $ffi->attach( tb_has_truecolor => ['void'] => 'int' );
    $ffi->attach( tb_has_egc       => ['void'] => 'int' );
    #
    our $TRUECOLOR  = tb_has_truecolor();
    our $uintattr_t = $TRUECOLOR ? 'uint32_t' : 'uint16_t';
    #
    $EXPORT_TAGS{api} = [
        qw[
            tb_init tb_init_file tb_init_fd tb_init_rwfd tb_shutdown
            tb_width tb_height
            tb_clear tb_set_clear_attrs
            tb_present
            tb_invalidate
            tb_set_cursor tb_hide_cursor
            tb_set_cell tb_set_cell_ex tb_extend_cell
            tb_set_input_mode
            tb_set_output_mode
            tb_peek_event
            tb_poll_event
            tb_get_fds
            tb_print
            tb_send
            tb_set_func
            tb_utf8_char_length tb_utf8_char_to_unicode tb_utf8_unicode_to_char
            tb_last_errno tb_strerror
            tb_cell_buffer
            tb_has_truecolor tb_has_egc
            tb_version
        ]
    ];
    #
    sub _export ($$) {
        my ( $tag, $values ) = @_;
        push @{ $EXPORT_TAGS{$tag} }, keys %$values;
        no strict 'refs';
        for my $key ( keys %$values ) {
            *{ __PACKAGE__ . '::' . $key } = sub () { $values->{$key} }
        }
    }
    #
    _export keys => {

        # Terminal-dependent key constants (tb_event.key) and terminfo capabilities
        TB_KEY_F1               => ( 0xFFFF - 0 ),
        TB_KEY_F2               => ( 0xFFFF - 1 ),
        TB_KEY_F3               => ( 0xFFFF - 2 ),
        TB_KEY_F4               => ( 0xFFFF - 3 ),
        TB_KEY_F5               => ( 0xFFFF - 4 ),
        TB_KEY_F6               => ( 0xFFFF - 5 ),
        TB_KEY_F7               => ( 0xFFFF - 6 ),
        TB_KEY_F8               => ( 0xFFFF - 7 ),
        TB_KEY_F9               => ( 0xFFFF - 8 ),
        TB_KEY_F10              => ( 0xFFFF - 9 ),
        TB_KEY_F11              => ( 0xFFFF - 10 ),
        TB_KEY_F12              => ( 0xFFFF - 11 ),
        TB_KEY_INSERT           => ( 0xFFFF - 12 ),
        TB_KEY_DELETE           => ( 0xFFFF - 13 ),
        TB_KEY_HOME             => ( 0xFFFF - 14 ),
        TB_KEY_END              => ( 0xFFFF - 15 ),
        TB_KEY_PGUP             => ( 0xFFFF - 16 ),
        TB_KEY_PGDN             => ( 0xFFFF - 17 ),
        TB_KEY_ARROW_UP         => ( 0xFFFF - 18 ),
        TB_KEY_ARROW_DOWN       => ( 0xFFFF - 19 ),
        TB_KEY_ARROW_LEFT       => ( 0xFFFF - 20 ),
        TB_KEY_ARROW_RIGHT      => ( 0xFFFF - 21 ),
        TB_KEY_BACK_TAB         => ( 0xffff - 22 ),
        TB_KEY_MOUSE_LEFT       => ( 0xffff - 23 ),
        TB_KEY_MOUSE_RIGHT      => ( 0xffff - 24 ),
        TB_KEY_MOUSE_MIDDLE     => ( 0xffff - 25 ),
        TB_KEY_MOUSE_RELEASE    => ( 0xffff - 26 ),
        TB_KEY_MOUSE_WHEEL_UP   => ( 0xffff - 27 ),
        TB_KEY_MOUSE_WHEEL_DOWN => ( 0xffff - 28 ),
        #
        TB_CAP_F1           => 0,
        TB_CAP_F2           => 1,
        TB_CAP_F3           => 2,
        TB_CAP_F4           => 3,
        TB_CAP_F5           => 4,
        TB_CAP_F6           => 5,
        TB_CAP_F7           => 6,
        TB_CAP_F8           => 7,
        TB_CAP_F9           => 8,
        TB_CAP_F10          => 9,
        TB_CAP_F11          => 10,
        TB_CAP_F12          => 11,
        TB_CAP_INSERT       => 12,
        TB_CAP_DELETE       => 13,
        TB_CAP_HOME         => 14,
        TB_CAP_END          => 15,
        TB_CAP_PGUP         => 16,
        TB_CAP_PGDN         => 17,
        TB_CAP_ARROW_UP     => 18,
        TB_CAP_ARROW_DOWN   => 19,
        TB_CAP_ARROW_LEFT   => 20,
        TB_CAP_ARROW_RIGHT  => 21,
        TB_CAP_BACK_TAB     => 22,
        TB_CAP__COUNT_KEYS  => 23,
        TB_CAP_ENTER_CA     => 23,
        TB_CAP_EXIT_CA      => 24,
        TB_CAP_SHOW_CURSOR  => 25,
        TB_CAP_HIDE_CURSOR  => 26,
        TB_CAP_CLEAR_SCREEN => 27,
        TB_CAP_SGR0         => 28,
        TB_CAP_UNDERLINE    => 29,
        TB_CAP_BOLD         => 30,
        TB_CAP_BLINK        => 31,
        TB_CAP_ITALIC       => 32,
        TB_CAP_REVERSE      => 33,
        TB_CAP_ENTER_KEYPAD => 34,
        TB_CAP_EXIT_KEYPAD  => 35,
        TB_CAP__COUNT       => 36
    };
    _export colors => {
        TB_DEFAULT   => 0x0000,
        TB_BLACK     => 0x0001,
        TB_RED       => 0x0002,
        TB_GREEN     => 0x0003,
        TB_YELLOW    => 0x0004,
        TB_BLUE      => 0x0005,
        TB_MAGENTA   => 0x0006,
        TB_CYAN      => 0x0007,
        TB_WHITE     => 0x0008,
        TB_BOLD      => 0x0100,
        TB_UNDERLINE => 0x0200,
        TB_REVERSE   => 0x0400,
        TB_ITALIC    => 0x0800,
        TB_BLINK     => 0x1000,
        TB_256_BLACK => 0x2000, (
            $TRUECOLOR ? (
                TB_TRUECOLOR_BOLD      => 0x01000000,
                TB_TRUECOLOR_UNDERLINE => 0x02000000,
                TB_TRUECOLOR_REVERSE   => 0x04000000,
                TB_TRUECOLOR_ITALIC    => 0x08000000,
                TB_TRUECOLOR_BLINK     => 0x10000000,
                TB_TRUECOLOR_BLACK     => 0x20000000,
                ) :
                ()
        )
    };
    _export event => {

        #~ Event types (tb_event.type)
        TB_EVENT_KEY    => 1,
        TB_EVENT_RESIZE => 2,
        TB_EVENT_MOUSE  => 3,

        #~ Key modifiers (bitwise) (tb_event.mod)
        TB_MOD_ALT    => 1,
        TB_MOD_CTRL   => 2,
        TB_MOD_SHIFT  => 4,
        TB_MOD_MOTION => 8,

        #~ Input modes (bitwise) (tb_set_input_mode)
        TB_INPUT_CURRENT => 0,
        TB_INPUT_ESC     => 1,
        TB_INPUT_ALT     => 2,
        TB_INPUT_MOUSE   => 4,

        #~ Output modes (tb_set_output_mode)
        TB_OUTPUT_CURRENT   => 0,
        TB_OUTPUT_NORMAL    => 1,
        TB_OUTPUT_256       => 2,
        TB_OUTPUT_216       => 3,
        TB_OUTPUT_GRAYSCALE => 4,
        ( $TRUECOLOR ? ( TB_OUTPUT_TRUECOLOR => 5 ) : () )
    };
    _export return => {
        TB_OK                   => 0,
        TB_ERR                  => -1,
        TB_ERR_NEED_MORE        => -2,
        TB_ERR_INIT_ALREADY     => -3,
        TB_ERR_INIT_OPEN        => -4,
        TB_ERR_MEM              => -5,
        TB_ERR_NO_EVENT         => -6,
        TB_ERR_NO_TERM          => -7,
        TB_ERR_NOT_INIT         => -8,
        TB_ERR_OUT_OF_BOUNDS    => -9,
        TB_ERR_READ             => -10,
        TB_ERR_RESIZE_IOCTL     => -11,
        TB_ERR_RESIZE_PIPE      => -12,
        TB_ERR_RESIZE_SIGACTION => -13,
        TB_ERR_POLL             => -14,
        TB_ERR_TCGETATTR        => -15,
        TB_ERR_TCSETATTR        => -16,
        TB_ERR_UNSUPPORTED_TERM => -17,
        TB_ERR_RESIZE_WRITE     => -18,
        TB_ERR_RESIZE_POLL      => -19,
        TB_ERR_RESIZE_READ      => -20,
        TB_ERR_RESIZE_SSCANF    => -21,
        TB_ERR_CAP_COLLISION    => -22
    };
    _export return =>
        { TB_ERR_SELECT => TB_ERR_POLL(), TB_ERR_RESIZE_SELECT => TB_ERR_RESIZE_POLL() };
    _export func => { TB_FUNC_EXTRACT_PRE => 0, TB_FUNC_EXTRACT_POST => 1 };
    #
    @EXPORT_OK          = sort map { @$_ = sort @$_; @$_ } values %EXPORT_TAGS;
    $EXPORT_TAGS{'all'} = \@EXPORT_OK;    # When you want to import everything

    #
    package                               #
        Termbox::Cell {
        use FFI::Platypus::Record;
        record_layout_1(
            uint32_t             => 'ch',
            $Termbox::uintattr_t => 'fg',
            $Termbox::uintattr_t => 'bg', (
                Termbox::tb_has_egc() ? ( 'opaque' => 'ech', size_t => 'nech', size_t => 'cech' ) :
                    ()
            )
        );
        };
    $ffi->type('record(Termbox::Cell)');
    #
    package    #
        Termbox::Event {
        use FFI::Platypus::Record;
        record_layout_1(
            qw[
                uint8_t  type
                uint8_t  mod
                uint16_t key
                uint32_t ch
                int32_t  w
                int32_t  h
                int32_t  x
                int32_t  y
            ]
        );
        };
    #
    $ffi->type('record(Termbox::Event)');
    #
    $ffi->attach( tb_init      => ['void']         => 'int' );
    $ffi->attach( tb_init_file => ['string']       => 'int' );
    $ffi->attach( tb_init_fd   => ['int']          => 'int' );
    $ffi->attach( tb_init_rwfd => [ 'int', 'int' ] => 'int' );
    $ffi->attach( tb_shutdown  => ['void']         => 'void' );
    #
    $ffi->attach( tb_width  => ['void'] => 'int' );
    $ffi->attach( tb_height => ['void'] => 'int' );
    #
    $ffi->attach( tb_clear           => ['void']                     => 'void' );
    $ffi->attach( tb_set_clear_attrs => [ $uintattr_t, $uintattr_t ] => 'void' );
    #
    $ffi->attach( tb_present => ['void'] => 'void' );
    #
    $ffi->attach( tb_invalidate => ['void'] => 'void' );
    #
    $ffi->attach( tb_set_cursor  => [ 'int', 'int' ] => 'void' );
    $ffi->attach( tb_hide_cursor => ['void']         => 'void' );
    #
    $ffi->attach(
        tb_set_cell => [ 'int', 'int', 'uint32_t', $uintattr_t, $uintattr_t ] => 'int',
        sub {
            my ( $xsub, $x, $y, $ch, $fg, $bg ) = @_;
            $xsub->( $x, $y, ord $ch, $fg, $bg );
        }
    );
    $ffi->attach(
        tb_set_cell_ex => [ 'int', 'int', 'uint32_t', 'size_t', $uintattr_t, $uintattr_t ] => 'int',
        sub {
            my ( $xsub, $x, $y, $ch, $nch, $fg, $bg ) = @_;
            $xsub->( $x, $y, ord $ch, $nch, $fg, $bg );
        }
    );
    $ffi->attach(
        tb_extend_cell => [ 'int', 'int', 'uint32_t' ] => 'int',
        sub {
            my ( $xsub, $x, $y, $ch ) = @_;
            $xsub->( $x, $y, ord $ch );
        }
    );
    #
    $ffi->attach( tb_set_input_mode => ['int'] => 'int' );
    #
    $ffi->attach( tb_set_output_mode => ['int'] => 'int' );
    #
    $ffi->attach( tb_peek_event => [ 'record(Termbox::Event)*', 'int' ] => 'int' );
    #
    $ffi->attach( tb_poll_event => ['record(Termbox::Event)*'] => 'int' );
    #
    $ffi->attach( tb_get_fds => [ 'int*', 'int*' ] => 'int' );
    #
    $ffi->attach( tb_print => [ 'int', 'int', $uintattr_t, $uintattr_t, 'string' ] => 'int' );

#~ int tb_printf(int x, int y, uintattr_t fg, uintattr_t bg, const char *fmt, ...);
#~ int tb_print_ex(int x, int y, uintattr_t fg, uintattr_t bg, size_t *out_w, const char *str);
#~ int tb_printf_ex(int x, int y, uintattr_t fg, uintattr_t bg, size_t *out_w, const char *fmt, ...);
#
    $ffi->attach( tb_send => [ 'string', 'size_t' ] => 'int' );
    #
    $ffi->type( '(opaque, opaque)->int' => 'closure_t' );   # int (*fn)(struct tb_event *, size_t *)
    $ffi->attach(
        tb_set_func => [ 'int', 'closure_t' ] => 'int',
        sub {
            CORE::state $cache;
            my ( $xsub, $fn_type, $func ) = @_;
            $cache->{$fn_type}->unsticky if $cache->{$fn_type};
            my $closure;
            if ($func) {
                $closure = $ffi->closure(
                    sub {
                        my ( $event, $size ) = @_;
                        $func->(
                            $ffi->cast( 'opaque', 'record(Termbox::Event)*', $event ),
                            $ffi->cast( 'opaque', 'size_t*',                 $size )
                        );
                    }
                );
                $closure->sticky;
            }
            $cache->{$fn_type} = $closure;
            $xsub->( $fn_type, $closure );
        }
    );
    #
    $ffi->attach( tb_utf8_char_length     => ['char']                   => 'int' );
    $ffi->attach( tb_utf8_char_to_unicode => [ 'uint32_t*', 'string*' ] => 'int' );
    $ffi->attach( tb_utf8_unicode_to_char => [ 'string', 'uint32_t' ]   => 'int' );
    $ffi->attach( tb_last_errno           => ['void']                   => 'int' );
    $ffi->attach( tb_strerror             => ['int']                    => 'string' );
    $ffi->attach( tb_cell_buffer          => ['void'] => 'record(Termbox::Cell)*' );

    # tb_has_truecolor and tbs_has_egc are defined near the top
    $ffi->attach( tb_version => ['void'] => 'string' );
}
1;
__END__