Beagle

 view release on metacpan or  search on metacpan

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

    my $bh;
    my $pid;

    if ( $self->info ) {
        $bh = current_handle();
        $pid = $bh->info->id;
    }
    elsif ( $self->parent ) {
        my @ret = resolve_entry( $self->parent, handle => current_handle() || undef );
        unless (@ret) {
            @ret = resolve_entry($pid) or die_entry_not_found($pid);
        }
        die_entry_ambiguous( $pid, @ret ) unless @ret == 1;
        $pid = $ret[0]->{id};
        $bh = $ret[0]->{handle};
    }

    if ( $self->add ) {
        my @added;
        for my $file (@$args) {
            if ( -f $file ) {

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

    die "beagle cast --type new_type id1 id2 [...]"
      unless @$args && $self->type;

    my $type      = lc $self->type;
    my $new_class = entry_type_info->{$type}{class};
    die "invalid type: $type" unless $new_class;

    for my $i (@$args) {
        my @ret = resolve_entry( $i, handle => current_handle() || undef );
        unless (@ret) {
            @ret = resolve_entry($i) or die_entry_not_found($i);
        }
        die_entry_ambiguous( $i, @ret ) unless @ret == 1;
        my $id    = $ret[0]->{id};
        my $bh    = $ret[0]->{handle};
        my $entry = $ret[0]->{entry};

        my $new_object = $new_class->new(%$entry);
        if (
            $bh->create_entry(
                $new_object, message => "cast $id to type $type"

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

sub execute {
    my ( $self, $opt, $args ) = @_;
    $args = $self->resolve_ids( $args );
    die "beagle cat id [...]" unless @$args;

    my $first = 1;
    for my $i (@$args) {
        my @ret = resolve_entry($i, handle => current_handle() || undef );
        unless (@ret) {
            @ret = resolve_entry($i) or die_entry_not_found($i);
        }

        die_entry_ambiguous( $i, @ret ) unless @ret == 1;
        my $id = $ret[0]->{id};
        my $bh = $ret[0]->{handle};
        my $entry = $ret[0]->{entry};

        puts '=' x term_width() unless $first;
        undef $first if $first;

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

sub execute {
    my ( $self, $opt, $args ) = @_;
    require Email::Address;

    my $pid = $self->parent;
    die "beagle comment --parent parent_id ..." unless $pid;

    my @ret = resolve_entry( $pid, handle => current_handle() || undef );
    unless (@ret) {
        @ret = resolve_entry($pid) or die_entry_not_found($pid);
    }
    die_entry_ambiguous( $pid, @ret ) unless @ret == 1;
    $pid = $ret[0]->{id};
    my $bh = $self->inplace ? $ret[0]->{handle} : current_handle();
    $bh ||= $ret[0]->{handle};

    my $author = $self->author || current_user() || '';

    my $body = join ' ', @$args;

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

    return super;
};

override 'filter' => sub {
    my $self  = shift;
    my @found = super;
    my $pid   = $self->parent;
    return @found unless defined $pid;
    my @ret = resolve_entry( $pid, handle => current_handle() || undef );
    unless (@ret) {
        @ret = resolve_entry($pid) or die_entry_not_found($pid);
    }
    die_entry_ambiguous( $pid, @ret ) unless @ret == 1;

    my $id = $ret[0]->{id};
    return grep { $_->parent_id eq $id } @found;
};

sub command_names { 'comments' };

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

no Any::Moose;
__PACKAGE__->meta->make_immutable;

sub execute {
    my ( $self, $opt, $args ) = @_;
    my ( $id, $entry, $bh );
    if ( $self->id ) {
        my $i = $self->id;
        my @ret = resolve_entry( $i, handle => current_handle() || undef );
        unless (@ret) {
            @ret = resolve_entry($i) or die_entry_not_found($i);
        }
        die_entry_ambiguous( $i, @ret ) unless @ret == 1;
        $id    = $ret[0]->{id};
        $bh    = $ret[0]->{handle};
        $entry = $ret[0]->{entry};
    }
    require Beagle::Handle;
    $bh ||= Beagle::Handle->new( root => current_root() );

    my ( $ret, $out ) =

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

        my @ids;
        $args = $self->resolve_ids( $args );
        for my $i (@$args) {
            if ( length $i == 32 ) {
                push @ids, $i;
            }
            else {
                my @ret = resolve_entry( $i, handle => current_handle() || undef );
                unless (@ret) {
                    @ret = resolve_entry($i) or die_entry_not_found($i);
                }
                die_entry_ambiguous( $i, @ret ) unless @ret == 1;
                push @ids, $ret[0]->{id};
            }
        }

        if ( $self->add || $self->delete || $self->set || $self->unset ) {

            for my $id (@ids) {

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

    my @created;
    my $relation;

    my $to_root = name_root($name) or die "no such beagle with name: $name";
    require Beagle::Handle;
    my $to = Beagle::Handle->new( root => $to_root );

    for my $i (@$args) {
        my @ret = resolve_entry( $i, handle => current_handle() || undef );
        unless (@ret) {
            @ret = resolve_entry($i) or die_entry_not_found($i);
        }
        die_entry_ambiguous( $i, @ret ) unless @ret == 1;
        my $id    = $ret[0]->{id};
        my $bh    = $ret[0]->{handle};
        my $entry = $ret[0]->{entry};
        if ( $bh->name eq $to->name ) {
            warn "$id is already in $name";
            next;
        }

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

    $args = $self->resolve_ids( $args );

    die "beagle rm id [...]" unless @$args;

    my @deleted;
    my $relation;

    for my $i (@$args) {
        my @ret = resolve_entry( $i, handle => current_handle() || undef );
        unless (@ret) {
            @ret = resolve_entry($i) or die_entry_not_found($i);
        }
        die_entry_ambiguous( $i, @ret ) unless @ret == 1 || $self->force;

        for my $ret (@ret) {
            my $id    = $ret->{id};
            my $bh    = $ret->{handle};
            my $entry = $ret->{entry};

            if ( $bh->delete_entry( $entry, message => $self->message ) ) {
                push @deleted, { handle => $bh, id => $entry->id };

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

    $args = $self->resolve_ids( $args );
    die 'beagle spread id1 id2 [...]' unless @$args;

    die "can't use both --template and --template-file"
      if defined $self->template && defined $self->template_file;

    my $cmd = $self->command;
    for my $i (@$args) {
        my @ret = resolve_entry( $i, handle => current_handle() || undef );
        unless (@ret) {
            @ret = resolve_entry($i) or die_entry_not_found($i);
        }
        die_entry_ambiguous( $i, @ret ) unless @ret == 1;
        my $id    = $ret[0]->{id};
        my $bh    = $ret[0]->{handle};
        my $entry = $ret[0]->{entry};

        my $msg;

        my $template;

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

sub execute {
    my ( $self, $opt, $args ) = @_;
    $args = $self->resolve_ids( $args );

    die "beagle update id [...]" unless @$args;

    for my $i (@$args) {
        my @ret = resolve_entry( $i, handle => current_handle() || undef );
        unless (@ret) {
            @ret = resolve_entry($i) or die_entry_not_found($i);
        }
        die_entry_ambiguous( $i, @ret ) unless @ret == 1;
        my $id    = $ret[0]->{id};
        my $bh    = $ret[0]->{handle};
        my $entry = $ret[0]->{entry};

        if ( $self->set ) {
            for my $item ( @{ $self->set } ) {
                my ( $key, $value ) = split /=/, $item, 2;
                if ( $entry->can($key) ) {

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

    };
}

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

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

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

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

        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;

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

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

t/api/01.util.t  view on Meta::CPAN

use Test::More;
use Beagle::Util;

my @subs = 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 core_config user_alias
  set_core_config set_user_alias roots set_roots 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 share_root resolve_entry
  is_in_range parse_wiki  parse_markdown parse_pod marks set_marks
  whitelist set_whitelist detect_roots
  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