view release on metacpan or  search on metacpan

lib/App/Basis.pm  view on Meta::CPAN

        s/=.*$// ;

        # Sort by length so single letter options are shown first.
        my @parts = sort { length $a <=> length $b } split /\|/ ;

        # Single chars get - prefix, names get -- prefix.
        my $s = join ", ", map { ( length > 1 ? '--' : '-' ) . $_ } @parts ;

        $descs{$o} = $s ;
    }
    return %descs ;
}

# ----------------------------------------------------------------------------
# special function to help us test this module, as it flags that we can die
# rather than exiting when doing some operations
# also test mode will not output to STDERR/STDOUT

sub set_test_mode
{
    $_test_mode = shift ;
}

# ----------------------------------------------------------------------------




# saymd function taken and modied from
# echomd -- An md like conversion tool for shell terminals
# https://raw.githubusercontent.com/WebReflection/echomd/master/perl/echomd
# some mod's of my own

#
# Fully inspired by the work of John Gruber
# <http://daringfireball.net/projects/markdown/>
#
# -----------------------------------------------------------------------------
# The MIT License (MIT)
# Copyright (c) 2016 Andrea Giammarchi - @WebReflection
#
# Permission is hereby granted, free of charge, to any person obtaining a
# copy of this software and associated documentation files (the "Software"),
# to deal in the Software without restriction, including without limitation
# the rights to use, copy, modify, merge, publish, distribute, sublicense,
# and/or sell copies of the Software, and to permit persons to whom
# the Software is furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included
# in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
# DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
# TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH
# THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
# -----------------------------------------------------------------------------

# for *bold* _underline_ ~strike~ (strike on Linux only)
# it works with both double **__~~ or just single *_~
sub _bold_underline_strike
{
    my ($txt) = @_ ;
    $txt =~ s/(\*{1,2})(?=\S)(.+?)(?<=\S)\1/\x1B[1m$2\x1B[22m/gs ;
    $txt =~ s/(\_{1,2})(?=\S)(.+?)(?<=\S)\1/\x1B[4m$2\x1B[24m/gs ;
    $txt =~ s/(\~{1,2})(?=\S)(.+?)(?<=\S)\1/\x1B[9m$2\x1B[29m/gs ;
    return $txt ;
}

# for #color(text) or bg#bgcolor(text)
# virtually compatible with #RGBA(text)
# or for background via bg#RGBA(text)
sub _color
{
    my ($txt) = @_ ;
    $txt =~ s{(bg)?#([a-zA-Z0-9]{3,8})\((.+?)\)(?!\))}
           {_get_color($1,$2,$3)}egs ;
    return $txt ;
}

# for very important # Headers
# and for less important ## One
sub _header
{
    my ($txt) = @_ ;
    $txt =~ s{^(\#{1,6})[ \t]+(.+?)[ \t]*\#*([\r\n]+|$)}
           {_get_header($1,$2).$3}egm ;
    return $txt ;
}

# for horizontal lines
# --- or - - - or ___ or * * *
sub _horizontal
{
    my ($txt) = @_ ;
    my $line = "─" x 72 ;
    $txt =~ s{^[ ]{0,2}([ ]?[\*_-][ ]?){3,}[ \t]*$}
           {\x1B[1m$line\x1B[22m}gm ;
    return $txt ;
}

# for lists such:
#   * list 1
#     etc, etc
#   * list 2
#   * list 3
sub _list
{
    my ($txt) = @_ ;
    $txt =~ s/^([ \t]{2,})[*+-]([ \t]{1,})/$1•$2/gm ;
    return $txt ;
}

# for quoted text such:
# > this is quote
# > this is the rest of the quote
sub _quote
{
    my ($txt) = @_ ;
    $txt =~ s/^[ \t]*>([ \t]?)/\x1B[7m$1\x1B[27m$1/gm ;
    return $txt ;

lib/App/Basis.pm  view on Meta::CPAN

        $out = "\x1B[31m" ;
    } elsif ( $rgb eq "green" ) {
        $out = "\x1B[32m" ;
    } elsif ( $rgb eq "blue" ) {
        $out = "\x1B[34m" ;
    } elsif ( $rgb eq "magenta" ) {
        $out = "\x1B[35m" ;
    } elsif ( $rgb eq "cyan" ) {
        $out = "\x1B[36m" ;
    } elsif ( $rgb eq "white" ) {
        $out = "\x1B[37m" ;
    } elsif ( $rgb eq "yellow" ) {
        $out = "\x1B[39m" ;
    } elsif ( $rgb eq "grey" ) {
        $out = "\x1B[90m" ;
    }
    $out .= ( $out eq "" ) ? $3 : "$3\x1B[39m" ;
    return ( !defined $bg ) ? $out : "\x1B[7m$out\x1B[27m" ;
}

sub _get_header
{
    my ( $hash, $txt ) = @_ ;
    if ( length($hash) eq 1 ) {
        $txt = "\x1B[1m$txt\x1B[22m" ;
    }
    return "\x1B[7m $txt \x1B[27m" ;
}

# used to place parsed code back
sub _get_source
{
    my ($hash) = @_ ;
    my %code = %{ $_[1] } ;
    for my $source ( keys %code ) {
        if ( $code{$source} eq $hash ) {
            return $source ;
        }
    }
}

# main transformer
# takes care of code blocks too
# without modifying their content
# inline `code blocks` as well as
# ```
# multiline code blocks
# ```
sub saymd
{
    my ($txt) = @_ ;
    my %code ;
    # preserve code blocks
    $txt =~ s{(`{2,})(.+?)(?<!`)\1(?!`)}
           {$1.($code{$2}=md5_base64($2)).$1}egs ;
    # preserve inline blocks too
    $txt =~ s{(`)(.+?)\1}{$1.($code{$2}=md5_base64($2)).$1}egm ;
    # converter everything else
    $txt = _horizontal($txt) ;
    $txt = _header($txt) ;
    $txt = _bold_underline_strike($txt) ;
    $txt = _list($txt) ;
    $txt = _quote($txt) ;
    $txt = _color($txt) ;
    # put back inline blocks
    $txt =~ s{(`)(.+?)\1}{$1._get_source($2,\%code).$1}egm ;
    # put back code blocks too
    $txt =~ s{(`{3})(.+?)(?<!`)\1(?!`)}
           {$1._get_source($2,\%code).$1}egs ;
    say $txt;
}

# ----------------------------------------------------------------------------
# make sure we do any cleanup required

END {

    # call any user supplied cleanup
    if ($_app_simple_cleanup_func) {
        $_app_simple_cleanup_func->() ;
        $_app_simple_cleanup_func = undef ;
    }
}


# ----------------------------------------------------------------------------

1 ;

__END__

=pod

=encoding UTF-8

=head1 NAME

App::Basis - Simple way to create applications

=head1 VERSION

version 1.2

=head1 SYNOPSIS

    use 5.10.0 ;
    use strict ;
    use warnings ;
    use POSIX qw(strftime) ;
    use App::Basis

    sub ctrlc_func {
        # code to decide what to do when CTRL-C is pressed
    }

    sub cleanup_func {
        # optionally clean up things when the script ends
    }

    sub debug_func {
        my ($lvl, $debug) = @_;