Beagle

 view release on metacpan or  search on metacpan

MANIFEST  view on Meta::CPAN

t/cli/02.init.t
t/cli/03.create.t
t/cli/04.comment.t
t/cli/05.att.t
t/cli/06.follow.t
t/cli/07.mark.t
t/cli/08.info.t
t/cli/09.config.t
t/cli/10.alias.t
t/cli/70.no_default_beagle.t
t/cli/80.locale.t
t/release-pod-syntax.t
t/web/01.walk.t

lib/Beagle/Backend/base.pm  view on Meta::CPAN

use Any::Moose;
use Beagle::Util;

has 'root' => (
    isa      => 'Str',
    is       => 'rw',
    required => 1,
    trigger  => sub {
        my $self  = shift;
        my $value = shift;
        $self->encoded_root( encode( locale_fs => $value ) );
    },
);

has 'encoded_root' => (
    isa => 'Str',
    is  => 'rw',
);

sub type {
    my $self = shift;

lib/Beagle/Backend/base.pm  view on Meta::CPAN

sub read {
    my $self = shift;
    my %args = @_;
    return unless -e $self->encoded_root;
    my $root             = $self->root;
    my $encoded_root     = $self->encoded_root;
    my $top_encoded_root = $encoded_root;

    if ( $args{path} ) {
        my $full_path =
          encode( locale_fs => catfile( $self->root, $args{path} ) );
        local $/;
        open my $fh, '<', $full_path or die $!;
        binmode $fh;
        return $args{path} => decode_utf8 <$fh>;
    }

    my $type = $args{type} || 'article';

    my %file;

lib/Beagle/Backend/base.pm  view on Meta::CPAN

        while ( my $dir = readdir $dh ) {
            if ( $dir =~ /^\w{2}$/ ) {
                opendir my $dh2, catdir( $encoded_root, $dir )
                  or die $!;
                while ( my $left = readdir $dh2 ) {
                    if ( $left =~ /^\w{30}$/ ) {
                        opendir my $dh3, catdir( $encoded_root, $dir, $left )
                          or die $!;

                        $file{ $dir . $left } = [
                            map { decode( locale_fs => $_ ) }
                            grep { $_ ne '.' && $_ ne '..' } readdir $dh3
                        ];
                    }
                }
            }
        }
        return %file;
    }
    else {
        require Lingua::EN::Inflect;

lib/Beagle/Backend/base.pm  view on Meta::CPAN

              or die $!;
            while ( my $left = readdir $dh2 ) {
                next unless $left =~ /^\w{30}$/;
                my $path = catfile( $root, $dir, $left );
                next unless -f $path;
                local $/;
                open my $fh, '<', $path or die $!;
                binmode $fh;
                $path =~ s!^\Q$top_encoded_root\E[/\\]?!!;
                $file{ $dir . $left } = {
                    path    => decode( locale_fs => $path ),
                    content => decode_utf8 <$fh>,
                };
            }
        }
    }
    return %file;
}

sub update {
    my $self   = shift;

lib/Beagle/Backend/fs.pm  view on Meta::CPAN

    my $object       = shift;

    my $path = $object->path;
    return unless $path;

    if (   $object->can('original_path')
        && $object->original_path
        && $object->original_path ne $object->path )
    {
        my $full_path =
          encode( locale_fs => catfile( $self->root, $object->path ) );
        my $parent = parent_dir($full_path);
        make_path($parent) unless -e $parent;

        rename(
            encode( locale_fs => $object->original_path ),
            encode( locale_fs => $object->path )
        ) or return;
        $object->original_path( $object->path );
    }

    my %args = @_;
    return $self->_save( $object, %args );
}

sub delete {
    my $self   = shift;
    my $object = shift;
    my %args   = @_;

    my $path = $object ? $object->path : $args{path};
    return unless $path;

    my $full_path = encode( locale_fs => catfile( $self->root, $path ) );
    return unless -e $full_path;

    if ( -f $full_path ) {
        unlink $full_path or return;
    }
    else {
        remove_tree($full_path) or return;
    }
    return 1;
}

sub _save {
    my $self   = shift;
    my $object = shift;
    my %args   = @_;

    my $path = $object->path;
    return unless $path;

    my $full_path = encode( locale_fs => catfile( $self->root, $path ) );

    my $parent = parent_dir($full_path);
    make_path($parent) unless -e $parent;

    if ( $object->can('content_file') && $object->content_file ) {
        require File::Copy;
        File::Copy::copy( encode( locale_fs => $object->content_file ),
            $full_path )
          or die $!;
    }
    else {
        my $string = $object->serialize;
        open my $fh, '>', $full_path or die $!;
        binmode $fh;
        unless ( $object->can('is_raw') && $object->is_raw ) {
            $string = encode_utf8 $string;
        }

lib/Beagle/Backend/git.pm  view on Meta::CPAN

    my $path = $object->path;
    return unless $path;

    my $ret = 1;

    if (   $object->can('original_path')
        && $object->original_path
        && $object->original_path ne $object->path )
    {
        my $full_path =
          encode( locale_fs => catfile( $self->root, $object->path ) );
        my $parent = parent_dir($full_path);
        make_path($parent) unless -e $parent;

        ($ret) = $self->git->mv( $object->original_path, $object->path );
        $object->original_path( $object->path );
    }

    my %args = ( commit => 1, @_ );
    $args{'message'} ||= $object->commit_message;

lib/Beagle/Backend/git.pm  view on Meta::CPAN

}

sub delete {
    my $self   = shift;
    my $object = shift;
    my %args   = ( commit => 1, @_ );

    my $path = $object ? $object->path : $args{path};
    return unless $path;

    my $full_path = encode( locale_fs => catfile( $self->root, $path ) );
    return unless -e $full_path;

    my ($ret) = $self->git->rm( '--force', '-r', $path );
    return unless $ret;
    ($ret) = $self->git->commit(
        -m => $args{message} || "delete $path",
        $path,
    );
    return $ret;
}

sub _save {
    my $self   = shift;
    my $object = shift;
    my %args   = ( commit => 1, @_ );

    my $path = $object->path;
    return unless $path;

    my $full_path = encode( locale_fs => catfile( $self->root, $path ) );

    my $parent = parent_dir($full_path);
    make_path($parent) unless -e $parent;

    if ( $object->can('content_file') && $object->content_file ) {
        require File::Copy;
        File::Copy::copy( encode( locale_fs => $object->content_file ),
            $full_path )
          or die $!;
    }
    else {
        my $string = $object->serialize;
        open my $fh, '>', $full_path or die $!;
        binmode $fh;
        unless ( $object->can('is_raw') && $object->is_raw ) {
            $string = encode_utf8 $string;
        }

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

package Beagle::Cmd;
use Any::Moose;
use Beagle::Util;
extends any_moose('X::App::Cmd');

before 'run' => sub {
    @ARGV = map { defined $_ ? decode( locale => $_ ) : $_ } @ARGV;

    if ( !@ARGV ) {
        my $command =
          $ENV{BEAGLE_DEFAULT_COMMAND}
          ? decode( locale => $ENV{BEAGLE_DEFAULT_COMMAND} )
          : core_config->{default_command};

        if ($command) {
            require Text::ParseWords;
            @ARGV = Text::ParseWords::shellwords($command);
        }
        else {
            @ARGV = 'shell';
        }
    }

lib/Beagle/Cmd/Command/create.pm  view on Meta::CPAN

    $bh->backend->commit( message => $entry->commit_message || $self->message );
    puts "created " . $entry->id . ".";
}

sub handle_attachments {
    my $self   = shift;
    my $parent = shift;
    return unless $self->attachments;
    for my $file ( @{ $self->attachments } ) {
        if ( -f encode( locale_fs => $file ) ) {

            require File::Basename;
            my $basename = File::Basename::basename($file);
            my $att      = Beagle::Model::Attachment->new(
                name         => $basename,
                content_file => $file,
                parent_id    => $parent->id,
            );

            current_handle()->create_attachment( $att, commit => 0 );

lib/Beagle/Cmd/Command/follow.pm  view on Meta::CPAN

        my $f_root = catdir( backends_root(), split /\//, $name );
        if ( -e $f_root ) {
            if ( $self->force ) {
                remove_tree($f_root);
            }
            else {
                die "$f_root already exists, use -f or --force to overwrite";
            }
        }

        my $parent = encode( locale_fs => parent_dir($f_root) );
        make_path($parent) or die "failed to create $parent" unless -d $parent;

        if ( $type eq 'git' ) {
            require Beagle::Wrapper::git;
            my $git = Beagle::Wrapper::git->new( verbose => $self->verbose );

            my $default    = core_config;
            my $user_name  = $default->{user_name};
            my $user_email = $default->{user_email};

lib/Beagle/Cmd/Command/init.pm  view on Meta::CPAN

    if ($root) {
        if ( -e $root ) {
            if ( $self->force ) {
                remove_tree($root);
            }
            else {
                die "$root already exists, use --force|-f to override";
            }
        }
    }
    make_path( encode( locale_fs => $root ) ) or die "failed to create $root";

    my $info;
    if ( $self->edit ) {
        require Beagle::Model::Info;
        my $template = encode_utf8 Beagle::Model::Info->new()->serialize;
        my $updated = edit_text($template);
        $info = Beagle::Model::Info->new_from_string( decode_utf8 $updated);
    }

    # $opt->{name} is not user name but beagle name

lib/Beagle/Cmd/Command/publish.pm  view on Meta::CPAN

    require Beagle::Web;

    Beagle::Web->init();
    $app = \&Beagle::Web::handle_request;

    require File::Copy::Recursive;
    for my $bh (@bh) {
        $handle = $bh;
        my $to = catdir( $self->to, $bh->name );
        my $encoded_to = encode( locale_fs => $to );
        if ( -e $encoded_to ) {
            if ( $self->force ) {
                remove_tree($encoded_to);
            }
            else {
                die "$encoded_to already exists, use --force|-f to override";
            }
        }

        make_path($encoded_to);

        chdir $encoded_to;

        my $system = encode( locale_fs => catdir( share_root(), 'public' ) );
        File::Copy::Recursive::dircopy( $system, 'system' );

        my $static = encode( locale_fs => static_root($bh) );
        mkdir( 'static' ) unless -e 'static';

        Beagle::Web::change_handle( handle => $bh );
        Beagle::Web::set_static(1);
        Beagle::Web::set_prefix('');

        $self->save_link( '/', 'index.html' );
        $self->save_link( '/about', );
        $self->save_link('/feed');
        $self->save_link('/tags');

lib/Beagle/Cmd/Command/publish.pm  view on Meta::CPAN

        }
    }
}

sub save_link {
    my $self = shift;
    my $link = shift or die 'need a link';
    my $file = shift;
    $file = $link unless defined $file;
    $file =~ s!^/!!;
    $file = encode( locale_fs => catfile( split m{/}, $file ) );

    my $res = $app->(
        {
            'PATH_INFO'            => $link,
            'REQUEST_METHOD'       => 'GET',
            'BEAGLE_NAME'          => $handle->name,
            'HTTP_ACCEPT_LANGUAGE' => $self->lang,
        }
    );
    die "failed to get $link: " if $res->[0] != 200;

lib/Beagle/Cmd/Command/rename.pm  view on Meta::CPAN

    my $all = roots();
    die "$old_name doesn't exist" unless $all->{$old_name};

    $all->{$new_name} = delete $all->{$old_name};

    $all->{$new_name}{local} =
      catdir( backends_root(), split qr{/}, $new_name );

    my $old_path =
      encode( locale_fs => catdir( backends_root(), split qr{/}, $old_name ) );
    my $new_path =
      encode( locale_fs => catdir( backends_root(), split qr{/}, $new_name ) );

    if ( -e $new_path ) {
        die "$new_path already exists, use --force|-f to override"
          unless $self->force;
        remove_tree($new_path) or die "failed to remove $new_path: $!";
    }

    my $new_parent = parent_dir( $new_path );
    make_path( $new_parent ) unless -e $new_parent;

lib/Beagle/Cmd/Command/unfollow.pm  view on Meta::CPAN

        else {
            die "$name doesn't exist, maybe a typo?";
        }

        my $f_root = catdir( backends_root(), split /\//, $name );
        if ( -e $f_root ) {
            remove_tree($f_root);
        }
        for my $t ( '', '.drafts' ) {
            my $cache =
              encode( locale_fs => catfile( cache_root(), $name . $t ) );
            remove_tree($cache) if -e $cache;
        }
        my $map = relation;
        for my $id ( keys %$map ) {
            delete $map->{$id} if $map->{$id} eq $name;
        }
        set_relation( $map );

        push @unfollowed, $name;
    }

lib/Beagle/Cmd/Command/web.pm  view on Meta::CPAN

    my $share_root = share_root();
    my $app = catfile( $share_root, 'app.psgi' );
    require Beagle::Web;
    local $ENV{BEAGLE_WEB_ADMIN} =
      exists $self->{admin} ? $self->admin : web_admin();
    local $ENV{BEAGLE_WEB_ALL} =
      exists $self->{all} ? $self->all : $ENV{BEAGLE_WEB_ALL};

    local $ENV{BEAGLE_WEB_NAMES} =
      $self->{names} ? encode( locale => $self->names ) : $ENV{BEAGLE_WEB_NAMES};

    require Plack::Runner;
    my $r = Plack::Runner->new;

    my @args;
    push @args, web_options(), @$args;

    if ( $self->command ) {
        system( $self->command, $app, @args );
    }

lib/Beagle/Cmd/GlobalCommand.pm  view on Meta::CPAN

has plugins => (
    isa           => 'Str',
    is            => 'rw',
    documentation => 'plugins to use',
    traits        => ['Getopt'],
    cmd_aliases   => 'x',
    trigger       => sub {
        my $self = shift;
        my $value = shift;
        undef $Beagle::Util::SEARCHED_PLUGINS;
        $ENV{BEAGLE_PLUGINS} = encode( locale => $value );
        Beagle::Util::plugins();
    },
);

sub resolve_ids {
    my $self = shift;
    my $args = shift;

    my @newargs;

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

);

has 'cache' => (
    isa     => 'Str',
    is      => 'ro',
    lazy    => 1,
    default => sub {
        my $self = shift;
        my $name = $self->name;
        my $file =
          encode( locale_fs =>
              catfile( cache_root(), $name . ( $self->drafts ? '.drafts' : '' ) )
          );
        my $parent = parent_dir($file);
        make_path( $parent ) unless -e $parent;
        return $file;
    },
);

has 'info' => (
    isa     => 'Beagle::Model::Info',

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

sub newline          { $NEWLINE }
sub is_windows       { $IS_WINDOWS }

sub puts {
    if (@_) {
        my @opt = @_;
        $opt[-1] =~ s!(\r?\n)*$!$NEWLINE!;

        print(
            encode(
                locale =>,
                join '',
                @opt,
            )
        );
    }
    else {
        print $NEWLINE;
    }
}

lib/Beagle/Role/File.pm  view on Meta::CPAN

use Any::Moose 'Role';
requires('path');

sub full_path {
    my $self = shift;
    return catfile( $self->root, $self->path );
}

sub size {
    my $self = shift;
    return file_size( encode( locale_fs => $self->full_path ) );
}

sub content {
    my $self = shift;
    local $/;
    open my $fh, '<', encode( locale_fs => $self->full_path ) or die $!;
    binmode $fh;
    return <$fh>;
}

no Any::Moose 'Role';
1;
__END__


=head1 AUTHOR

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

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

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

    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} ) {
        push @SPREAD_TEMPLATE_ROOTS, split /\s*,\s*/,
          core_config()->{spread_template_roots};
    }

    for my $plugin ( reverse plugins() ) {
        if ( try_load_class($plugin) ) {
            my $root = catdir( share_root($plugin), 'spread_templates' );

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

    push @SPREAD_TEMPLATE_ROOTS, catdir( share_root(), 'spread_templates' );
    @SPREAD_TEMPLATE_ROOTS = uniq @SPREAD_TEMPLATE_ROOTS;
    return @SPREAD_TEMPLATE_ROOTS;
}

sub web_template_roots {
    return @WEB_TEMPLATE_ROOTS if @WEB_TEMPLATE_ROOTS;
    @WEB_TEMPLATE_ROOTS = ();
    if ( $ENV{BEAGLE_WEB_TEMPLATE_ROOTS} ) {
        push @WEB_TEMPLATE_ROOTS, split /\s*,\s*/,
          decode( locale(), $ENV{BEAGLE_WEB_TEMPLATE_ROOTS} );
    }

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

    for my $plugin ( reverse plugins() ) {
        if ( try_load_class($plugin) ) {
            my $root = catdir( share_root($plugin), 'views' );

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};
        }

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

    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;
        }
    }

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

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} );
    }
    else {
        $BACKENDS_ROOT = core_config()->{backends_root}
          || catfile( kennel(), 'roots' );
    }
    return $BACKENDS_ROOT;
}

my $config;

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

    }
    else {
        $config = $value;
    }

    my $input = Config::INI::Writer->preprocess_input($config);
    eval { Config::INI::Writer->validate_input( $input ) };
    die $@ if $@;

    my $config_file = catfile( kennel(), 'config' );
    my $parent = encode( locale_fs => parent_dir($config_file) );
    make_path( parent_dir($config_file) ) or die $! unless -e $parent;
    open my $fh, '>:encoding(utf8)', $config_file or die $!;

    return Config::INI::Writer->write_handle( $config, $fh );
}

sub core_config { exists config()->{'core'} ? config()->{'core'} : {} }
sub user_alias  { exists config()->{alias}  ? config()->{alias}  : {} }
sub set_core_config { set_config( @_, 'core' ) }
sub set_user_alias  { set_config( @_, 'alias' ) }

sub whitelist {
    my $file = catfile( kennel(), 'whitelist' );
    return [] unless -e $file;
    return [ map { /(\S.*\S)/ ? $1 : () } read_file($file) ];
}

sub set_whitelist {
    my $value = @_ > 1 ? [@_] : shift;
    my $file = encode( locale_fs => catfile( kennel(), 'whitelist' ) );
    my $parent = parent_dir($file);
    make_path( parent_dir($file) ) or die $! unless -e $parent;

    write_file( $file,
        ref $value eq 'ARRAY' ? ( join newline, @$value ) : $value );
}

sub roots {
    my $config = config();
    my %roots;

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

    for my $name ( keys %$all ) {
        $config->{"roots/$name"} = $all->{$name};
    }
    set_config($config);
}

sub relation_path {
    return $RELATION_PATH if defined $RELATION_PATH;

    if ( $ENV{BEAGLE_RELATION_PATH} ) {
        $RELATION_PATH = decode( locale => $ENV{BEAGLE_RELATION_PATH} );
    }
    else {
        $RELATION_PATH = core_config()->{relation_path}
          || catfile( kennel(), '.relation' );
    }
    return $RELATION_PATH;
}

sub relation {
    my $file = relation_path();

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

sub set_relation {
    my $map = shift or return;
    nstore( $map, relation_path() );
}

sub marks_path {
    return $MARKS_PATH if defined $MARKS_PATH;

    if ( $ENV{BEAGLE_MARKS_PATH} ) {
        $MARKS_PATH = decode( locale => $ENV{BEAGLE_MARKS_PATH} );
    }
    else {
        $MARKS_PATH = core_config()->{marks_path}
          || catfile( kennel(), '.marks' );
    }
    return $MARKS_PATH;
}

sub marks {
    my $file = marks_path();

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

    my $roots = roots();
    for my $name ( keys %$roots ) {
        if ( $root eq $roots->{$name}{local} ) {
            $root_type{$root} = $roots->{$name}{type};
            last;
        }
    }

    $root_type{$root} ||=
      -e encode( locale_fs => catdir( $root, '.git' ) ) ? 'git' : 'fs';
    return $root_type{$root};
}

my $entry_type_info;

sub entry_type_info {
    return dclone($entry_type_info) if $entry_type_info;

    require Module::Pluggable::Object;
    my $models =

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

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

    require Beagle::Model::Info;
    my $info = $opt{'info'} || Beagle::Model::Info->new(
        ( $name  ? ( name  => $name )  : () ),
        ( $email ? ( email => $email ) : () ),
        root => '',
    );
    write_file( encode( locale_fs => catfile( $root, 'info' ) ), $info->serialize )
      or die $!;

    return 1;
}

sub _create_backend_git {
    my %opt  = @_;
    my $root = $opt{root};

    my $git;

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

}

sub detect_roots {
    my $base = shift || backends_root();
    return {} unless -d $base;
    my $info = {};

    opendir my $dh, $base or die $!;
    while ( my $dir = readdir $dh ) {
        next if $dir eq '.' || $dir eq '..';
        if ( check_root( decode( locale_fs => catdir( $base, $dir ) ) ) ) {

            if ( -e catdir( $base, $dir, '.git' ) ) {
                require Beagle::Wrapper::git;
                my $git =
                  Beagle::Wrapper::git->new( root => catdir( $base, $dir ) );
                my $url = $git->config( '--get', 'remote.origin.url' );
                chomp $url;
                $info->{ decode( locale_fs => $dir ) } = {
                    remote => $url,
                    local  => catdir( $base, $dir ),
                    type   => 'git',
                    trust  => 0,
                };
            }
            else {
                $info->{ decode( locale_fs => $dir ) } = {
                    local => catdir( $base, $dir ),
                    type  => 'fs',
                    trust => 0,
                };
            }
        }
        else {
            %$info = ( %$info, %{ detect_roots( catdir( $base, $dir ) ) } );
        }
    }

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

}

sub share_root {
    my $module = shift || 'Beagle';
    return $SHARE_ROOT{$module} if $SHARE_ROOT{$module};

    load_class($module);
    if ( $module eq 'Beagle' ) {
        if ( $ENV{BEAGLE_SHARE_ROOT} ) {
            $SHARE_ROOT{$module} =
              rel2abs( decode( locale => $ENV{BEAGLE_SHARE_ROOT} ) );
        }
        elsif ( core_config()->{share_root} ) {
            $SHARE_ROOT{Beagle} = rel2abs( core_config()->{share_root} );
        }
        return $SHARE_ROOT{$module} if $SHARE_ROOT{$module};
    }
    my $name  = $module;
    my $depth = $name =~ s!::!/!g;
    $name .= '.pm';
    my $path = $INC{$name};

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

      : defined core_config()->{web_admin} ? core_config()->{web_admin}
      :                                      0;

    return $WEB_ADMIN;
}

sub web_names {
    return @WEB_NAMES if $SEARCHED_WEB_NAMES;
    if ( $ENV{BEAGLE_WEB_NAMES} ) {
        @WEB_NAMES = split /\s*,\s*/,
          decode( locale => $ENV{BEAGLE_WEB_NAMES} );
    }
    elsif ( core_config()->{web_names} ) {
        @WEB_NAMES = split /\s*,\s*/, core_config->{web_names};
    }

    $SEARCHED_WEB_NAMES = 1;
    return @WEB_NAMES;
}

sub plugins {
    return @PLUGINS if $SEARCHED_PLUGINS;
    @PLUGINS = ();
    if ( $ENV{BEAGLE_PLUGINS} ) {
        push @PLUGINS, split /\s*,\s*/,
          decode( locale => $ENV{BEAGLE_PLUGINS} );
    }

    if ( core_config()->{plugins} ) {
        push @PLUGINS, split /\s*,\s*/,
          core_config()->{plugins};
    }
    $SEARCHED_PLUGINS = 1;

    @PLUGINS = uniq
      map { /^Beagle::Plugin::/ ? $_ : "Beagle::Plugin::$_" }

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

    shift @_ if @_ && $_[0] eq 'Beagle::Web';
    my $name = shift;
    return unless defined $name;
    $name .= '.tx' unless $name =~ /\.tx$/;
    my @roots = (
        map( { catdir( $_, $bh->info->layout ), } web_template_roots() ),
        map( { catdir( $_, 'base' ), } web_template_roots() )
    );
    my @parts = split /\//, $name;
    for my $root (@roots) {
        return 1 if -e encode( locale_fs => catfile( $root, @parts ) );
    }
    return;
}

sub system_file_exists {
    shift @_ if @_ && $_[0] eq 'Beagle::Web';
    my $name = shift;
    return unless defined $name;
    my @roots = system_roots();
    my @parts = split /\//, $name;
    for my $root (@roots) {
        return 1 if -e encode( locale_fs => catfile( $root, @parts ) );
    }
    return;
}

use Text::Xslate;

sub xslate {
    shift @_ if @_ && $_[0] eq 'Beagle::Web';
    my $n = shift   || $name;
    my $b = $bh{$n} || $bh;

lib/Beagle/Web/Router.pm  view on Meta::CPAN

    }
    else {
        redirect '/system/images/beagle.png';
    }
};

get '/static/*' => sub {
    my %vars = @_;
    my @parts = split '/', decode_utf8 $vars{splat}[0];
    my $file =
      encode( 'locale_fs',
        catfile( static_root( handle() ), @parts ) );
    return unless -e $file && -r $file;

    content_type( mime_type($file) );
    return scalar read_file $file;
};

post '/utility/markitup' => sub {
    my $data = request()->param('data');
    return unless $data;

lib/Beagle/Web/Router.pm  view on Meta::CPAN

get '/admin/term' => sub {
    render('admin/term');
};

post '/admin/term' => sub {
    my $data;
    content_type('application/json');

    eval { $data = from_json( request()->content, { utf8 => 1 } ) };
    if ( $@ ) {
        return to_json( { error => { message => decode( locale => $@ ) } } );
    }
    else {

        my $params = $data->{params} || [];

        local $ENV{BEAGLE_WEB_TERM} = 1;
        local @ARGV = ( $data->{method}, @$params );
        my $out;
        open my $out_fh, '>', \$out or die $!;
        local *STDOUT = $out_fh;
        local *STDERR = $out_fh;

        eval { Beagle::Cmd->run };
        my $ret = { id => $data->{id} };
        if ($@) {
            $ret->{error}{message} = decode( locale => $@ );
        }
        else {
            $ret->{result} = decode( locale => $out );
        }
        return to_json($ret);
    }
};

1;

__END__

=head1 AUTHOR

lib/Beagle/Wrapper/git.pm  view on Meta::CPAN

package Beagle::Wrapper::git;
use Beagle::Util;
use Any::Moose;
has 'root' => (
    isa     => 'Str',
    is      => 'rw',
    trigger => sub {
        my $self  = shift;
        my $value = shift;
        $self->encoded_root( encode( locale_fs => $value ) );
    },
);

has 'encoded_root' => (
    isa => 'Str',
    is  => 'rw',
);

has 'verbose' => (
    isa     => 'Bool',

lib/Beagle/Wrapper/git.pm  view on Meta::CPAN

    for my $item (@_) {
        if ($is_message) {
            push @args, encode_utf8 $item;
            $is_message = 0;
        }
        elsif ( $item eq '-m' || $item eq '--message' ) {
            $is_message = 1;
            push @args, $item;
        }
        else {
            push @args, encode( locale => $item );
        }
    }

    unshift @args, $ENV{BEAGLE_GIT_PATH} || 'git';
    require IPC::Run3;
    if ( $self->verbose ) {
        IPC::Run3::run3( [@args], undef );
    }
    else {
        IPC::Run3::run3( [@args], undef, \$out, \$err );

t/cli/80.locale.t  view on Meta::CPAN

$ENV{BEAGLE_NAME} = '丙丁';
run_ok( $beagle_cmd, [qw/which/], 'which cmd' );
is( last_script_stdout(), '丙丁' . newline(), 'current beagle' );

run_ok( $beagle_cmd, [qw/bark test -n 丙丁/], 'create bark' );
ok( last_script_stdout() =~ /^created (\w{32}).\s+$/, 'create bark output' );

opendir my $dh, catdir( $ENV{BEAGLE_KENNEL}, 'cache' );
my ($file) =
  map { decode( locale_fs => $_ ) }
  grep { $_ ne '.' && $_ ne '..' } readdir $dh;
is( $file, decode( 'utf8', '丙丁.drafts' ), 'cache is enabled' );

run_ok( $beagle_cmd, [qw/unfollow 丙丁/], 'create bark' );
is(
    last_script_stdout(),
    'unfollowed 丙丁.' . newline(),
    'unfollow 丙丁 output'
);