view release on metacpan or  search on metacpan

lib/Beagle/Util.pm  view on Meta::CPAN

package Beagle::Util;

use warnings;
use strict;
use Beagle::Helper;
use base 'Exporter';
use Config::INI::Reader;
use Config::INI::Writer;
use Any::Moose 'Util::TypeConstraints';
use Lingua::EN::Inflect 'PL';

# to handle checkbox input.
coerce 'Bool' => from 'Ref' => via { 1 };

enum 'BeagleBackendType' => [qw/git fs/];
enum 'BeagleFormat'      => [qw/plain markdown wiki pod html/];
enum 'BeagleLayout'      => [qw/blog plain/];
enum 'BeagleTheme'       => [qw/orange blue dark/];

our %ABBREV = map { $_ => 1 } qw/isbn/;

our (
    $ROOT,               $KENNEL,         $CACHE,
    $DEVEL,              %SHARE_ROOT,     @SPREAD_TEMPLATE_ROOTS,
    @WEB_TEMPLATE_ROOTS, $RELATION_PATH, $MARKS_PATH,
    $CACHE_ROOT, $BACKENDS_ROOT, $WEB_OPTIONS, $WEB_ALL,
    @PLUGINS, $SEARCHED_PLUGINS, @PO_ROOTS, $HANDLES,
    @WEB_NAMES, $SEARCHED_WEB_NAMES, $WEB_ADMIN, @SYSTEM_ROOTS,
    $CURRENT_USER,
);

BEGIN {

# I got error: "Goto undefined subroutine &die" on windows strawberry 5.12.2
# &CORE::die doesn't help

    *CORE::GLOBAL::die = sub {
#        goto &die unless ( caller() )[0] =~ /^Beagle::/;
        return die @_ unless ( caller() )[0] =~ /^Beagle::/;

        @_ = map { encode( locale => $_ ) } @_;
        return confess @_ if enabled_devel();

        # we want to show user the line info if there is nothing to print
        push @_, newline() if @_;

        @_ = grep { defined } @_;
        die @_;
    };

    *CORE::GLOBAL::warn = sub {
# interesting, I get warn if use goto &warn:
# Goto undefined subroutine &Beagle::Util::warn
#       goto &warn unless (caller())[0] =~ /^Beagle::/;
        return warn @_ unless ( caller() )[0] =~ /^Beagle::/;

        @_ = grep { defined } @_;

        # we want to show user the line info if there is nothing to print
        push @_, newline() if @_;
        @_ = map { encode( locale => $_ ) } @_;
        warn @_;
    };
}

our @EXPORT = (
    @Beagle::Helper::EXPORT, qw/
      enabled_devel enable_devel disable_devel enabled_cache enable_cache disable_cache
      set_current_root current_root root_name set_current_root_by_name check_root
      static_root kennel user_alias roots set_roots
      core_config set_core_config set_user_alias relation set_relation
      default_format split_id root_name name_root root_type
      system_alias create_backend alias aliases resolve_id die_entry_not_found
      die_entry_ambiguous current_handle handles resolve_entry
      is_in_range parse_wiki  parse_markdown parse_pod
      whitelist set_whitelist
      detect_roots backends_root cache_root
      share_root marks set_marks
      spread_template_roots web_template_roots
      entry_type_info entry_types
      relation_path marks_path
      web_options tweak_name plugins po_roots
      web_all web_names web_admin
      system_roots current_user
      /
);

$DEVEL =
  defined $ENV{BEAGLE_DEVEL} && length $ENV{BEAGLE_DEVEL}
  ? ( $ENV{BEAGLE_DEVEL} ? 1 : 0 )
  : ( exists core_config()->{devel} ? core_config()->{devel} : 1 );

sub enabled_devel {
    return $DEVEL ? 1 : 0;
}

sub enable_devel {
    $DEVEL = 1;
}

sub disable_devel {
    undef $DEVEL;
    return 1;
}

$CACHE =
  defined $ENV{BEAGLE_CACHE} && length $ENV{BEAGLE_CACHE}
  ? ( $ENV{BEAGLE_CACHE} ? 1 : 0 )
  : ( exists core_config()->{cache} ? core_config()->{cache} : 1 );

sub enabled_cache {
    return $CACHE ? 1 : 0;
}

sub enable_cache {