Beagle

 view release on metacpan or  search on metacpan

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

131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
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

19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
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

25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
 
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

54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
 
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

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
    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

14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
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

154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
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

25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
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

29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
$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

72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
$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

40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
 
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

63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
    };
}
 
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

238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
        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

715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
        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

744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
        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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
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