/[Frey]/trunk/lib/Frey/Class/Create.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /trunk/lib/Frey/Class/Create.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1089 - (show annotations)
Sun Jun 28 15:42:05 2009 UTC (14 years, 10 months ago) by dpavlin
File size: 2178 byte(s)
create correct paths for tests in t/SubDirectory
1 package Frey::Class::Create;
2 use Moose;
3
4 extends 'Frey';
5 with 'Frey::Web';
6 with 'Frey::Path';
7 #with 'Frey::Storage';
8
9 use File::Slurp;
10
11 has class => (
12 documentation => 'Name of class to create',
13 is => 'rw',
14 isa => 'Str',
15 required => 1,
16 default => 'App::Skeleton',
17 );
18
19 has svk_add => (
20 documentation => 'Add created files to SVK',
21 is => 'rw',
22 isa => 'Bool',
23 required => 1,
24 default => 1,
25 );
26
27 sub create_class_source_as_markup {
28 my ($self) = @_;
29
30 my $class = $self->class;
31
32 my $class_path = $class;
33 $class_path =~ s{::}{/}g;
34 $class_path = "lib/$class_path.pm";
35
36 my $test_path;
37
38 my @c = split(m{::}, $class);
39 foreach ( -1 .. $#c ) {
40 my $to = $#c - $_;
41 my $path = 't/' . join('/', @c[ 0 .. $to ] );
42 if ( -e $path ) {
43 my $file = join('-', @c[ $to + 1 .. $#c ] );
44 $test_path = $path . '/' . $file . '.t';
45 last;
46 }
47 }
48
49 die "no test_path from $class" unless $test_path;
50
51 die qq|class "$class" exists as |, $self->path_size($class_path) if -e $class_path;
52 die qq|class "$class" test exists as |, $self->path_size($test_path) if -e $test_path;
53
54 warn "## path $class_path";
55 $self->mkbasepath( $class_path );
56
57 my $skeleton = 'Frey::Skeleton';
58
59 my $code = read_file( 'lib/Frey/Skeleton.pm' );
60 $code =~ s{$skeleton}{$class}g;
61 write_file( $class_path, $code );
62 warn "# created class $class at ", $self->path_size($class_path);
63 system "svk add $class_path" if $self->svk_add;
64
65 $code = read_file( 't/30-frey-skeleton.t' );
66 $code =~ s{$skeleton}{$class}g;
67 write_file( $test_path, $code );
68 chmod 0755, $test_path;
69 warn "# created class $class at ", $self->path_size($test_path);
70 system "svk add $test_path" if $self->svk_add;
71
72 my $html
73 = qq|Created class "$class" at |
74 . $self->path_size($class_path)
75 . qq| and test |
76 . $self->path_size($test_path)
77 ;
78
79 $html = $self->html_links( $html );
80
81 return $html;
82 }
83
84 =head1 DESCRIPTION
85
86 Create Frey class based on L<Frey::Skeleton>.
87
88 Blame this on my Smalltalk influence, because creating classes there is just
89 interface and message sends wrapped in GUI, but that makes Smalltalk books
90 much harder to read...
91
92 On the other hand, having handy class creator within L<Frey> makes sense.
93
94 =cut
95
96 1;

  ViewVC Help
Powered by ViewVC 1.1.26