Beagle
13 results

 view release on metacpan or  search on metacpan

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

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 {
    $CACHE = 1;
}

sub disable_cache {
    undef $CACHE;
    return 1;
}

sub spread_template_roots {
    return @SPREAD_TEMPLATE_ROOTS if @SPREAD_TEMPLATE_ROOTS;
    @SPREAD_TEMPLATE_ROOTS = ();

    if ( $ENV{BEAGLE_SPREAD_TEMPLATE_ROOTS} ) {
        push @SPREAD_TEMPLATE_ROOTS, split /\s*,\s*/,
          decode( locale => $ENV{BEAGLE_SPREAD_TEMPLATE_ROOTS} );
    }

    if ( core_config()->{spread_template_roots} ) {

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

            }
        }
    }

    if ( core_config()->{po_roots} ) {
        push @PO_ROOTS, split /\s*,\s*/,
          core_config()->{po_roots};
    }

    if ( $ENV{BEAGLE_PO_ROOTS} ) {
        push @PO_ROOTS, split /\s*,\s*/,
          decode( locale(), $ENV{BEAGLE_PO_ROOTS} );
    }

    @PO_ROOTS = uniq @PO_ROOTS;
    return @PO_ROOTS;
}

sub set_current_root {
    my $dir;
    if (@_) {
        $dir = shift;
        die "set_current_root is called with an undef value"
          unless defined $dir;
    }
    else {
        $dir = decode( locale => $ENV{BEAGLE_ROOT} || '' );

        if ( !$dir && length $ENV{BEAGLE_NAME} ) {
            my $roots = roots();
            my $b = $roots->{ decode( locale => $ENV{BEAGLE_NAME} ) };
            $dir = $b->{local} if $b && $b->{local};
        }

        $dir ||= core_config()->{default_root};

        if ( !$dir && length core_config()->{default_name} ) {
            my $roots = roots();
            my $b     = $roots->{ core_config()->{default_name} };
            $dir = $b->{local} if $b && $b->{local};
        }
    }

    die
"couldn't find backend root, please specify env BEAGLE_NAME or BEAGLE_ROOT"
      unless $dir;

    $dir = rel2abs($dir);

    if ( check_root($dir) ) {
        return $ROOT = $dir;
    }
    else {
        die "$dir is invalid backend root";
    }
}

sub current_root {
    return $ROOT if defined $ROOT;

    my $not_die = shift;
    eval { set_current_root() };
    if ( $@ && !$not_die ) {
        die $@;
    }
    return $ROOT if $ROOT;
    return;
}

sub set_current_root_by_name {
    my $name = shift or die 'need name';

    return set_current_root( name_root($name) );
}

sub check_root {
    my $dir = encode( locale_fs => $_[-1] );
    return unless $dir && -d $dir;
    my $info = catfile( $dir, 'info' );
    if ( -e $info ) {
        open my $fh, '<', $info or die $!;
        local $/;
        my $content = <$fh>;
        if ( $content && $content =~ /id:/ ) {
            return 1;
        }
    }
    return;
}

sub static_root {
    my $handle = shift;
    return catdir( ( $handle ? $handle->root : current_root() ),
        'attachments' );
}

sub kennel {
    return $KENNEL if $KENNEL;
    if ( $ENV{BEAGLE_KENNEL} ) {
        $KENNEL = decode( locale => $ENV{BEAGLE_KENNEL} );
    }
    else {
        $KENNEL = catdir( user_home, '.beagle' );
    }
    return $KENNEL;
}

sub cache_root {
    return $CACHE_ROOT if $CACHE_ROOT;
    if ( $ENV{BEAGLE_CACHE_ROOT} ) {
        $CACHE_ROOT = decode( locale => $ENV{BEAGLE_CACHE_ROOT} );
    }
    else {
        $CACHE_ROOT = core_config()->{cache_root}
          || catfile( kennel(), 'cache' );
    }
    return $CACHE_ROOT;
}

sub backends_root {
    return $BACKENDS_ROOT if $BACKENDS_ROOT;
    if ( $ENV{BEAGLE_BACKENDS_ROOT} ) {
        $BACKENDS_ROOT = decode( locale => $ENV{BEAGLE_BACKENDS_ROOT} );

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

    my $name  = $opt{'name'};
    my $email = $opt{'email'};

    if ($name) {
        $git->config( '--add', 'user.name', $name );
    }

    if ($email) {
        $git->config( '--add', 'user.email', $email );
    }

    _create_backend_fs( %opt, root => $git->root );

    $git->add('.');
    $git->commit( '-m' => "init beagle $name" );

    if ( $opt{bare} ) {
        $git->push( 'origin', 'master' );
    }
    return 1;
}

sub alias {
    return { %{ system_alias() }, %{ user_alias() } };
}

sub aliases {
    return keys %{ alias() };
}

sub resolve_entry {
    my $str = shift or return;
    return resolve_id( $str, @_ ) if $str =~ /^[a-z0-9]+$/;
    return unless $str =~ s/^://;

    my %opt = ( handle => undef, @_ );

    require Beagle::Handle;
    my @bh;
    if ( $opt{handle} ) {
        push @bh, $opt{handle};
    }
    else {
        my $all = roots();
        @bh = map { Beagle::Handle->new( root => $all->{$_}{local} ) }
          keys %{$all};
    }

    my @found;
    for my $bh (@bh) {
        for my $entry ( @{ $bh->entries } ) {
            if ( $entry->serialize( id => 1 ) =~ qr/$str/im ) {
                push @found,
                  { id => $entry->id, entry => $entry, handle => $bh };
            }
        }
    }
    return @found;
}

sub die_not_found {
    my $str = shift;
    die "no such entry match $str";
}

sub resolve_id {
    my $i = shift or return;
    my %opt = ( handle => undef, @_ );
    my $bh = $opt{'handle'};

    require Beagle::Handle;
    if ($bh) {
        my @ids = grep { /^$i/ } keys %{ $bh->map };
        return
          map { { id => $_, entry => $bh->map->{$_}, handle => $bh } } @ids;
    }
    else {
        my $relation = relation;
        my @ids = grep { /^$i/ } keys %$relation;
        my @ret;
        for my $i (@ids) {
            my $root = name_root( $relation->{$i} );
            my $bh = Beagle::Handle->new( root => $root );
            push @ret, { id => $i, entry => $bh->map->{$i}, handle => $bh };
        }
        return @ret;
    }
}

sub die_entry_not_found {
    my $i = shift;
    die "no such entry matching $i";
}

sub die_entry_ambiguous {
    my $i     = shift;
    my @items = @_;
    my @out   = "ambiguous '$i':";
    for my $item (@items) {
        push @out, join( ' ', $item->{id}, $item->{entry}->summary(10) );
    }
    die join newline(), @out;
}

sub current_handle {
    my $root = current_root('not die');
    require Beagle::Handle;

    if ($root) {
        return Beagle::Handle->new( root => $root, @_ );
    }
    return;
}

sub handles {
    return $HANDLES if $HANDLES;
    my $all = roots();
    require Beagle::Handle;
    $HANDLES = {
        map { $_ => Beagle::Handle->new( root => $all->{$_}{local} ) }
          keys %$all
    };
    return $HANDLES;
}

sub is_in_range {
    my ( $entry, %limit ) = @_;

    my $created = $entry->created;
    my $updated = $entry->updated;

    # if on the exact epoch, before doesn't include the point, after does
    return if $limit{'created_before'} && $created >= $limit{'created_before'};
    return if $limit{'created_after'}  && $created < $limit{'created_after'};
    return if $limit{'updated_before'} && $updated >= $limit{'updated_before'};
    return if $limit{'updated_after'}  && $updated < $limit{'updated_after'};
    return 1;
}

my $whitelist = whitelist() || [];

use HTML::Defang;
my $defang = HTML::Defang->new(
    fix_mismatched_tags => 1,
    url_callback        => sub {
        my ( $self, $defang, $tag, $key, $val ) = @_;
        if ( $tag eq 'a' && $key eq 'href' && $$val && $$val =~ /^http/ ) {
            require URI;
            my $uri  = URI->new($$val);
            my $host = $uri->host;



( run in 1.155 second using v1.01-cache-2.11-cpan-0bb4e1dffa6 )