1package DBIx::Class::Candy::ResultSet;
2$DBIx::Class::Candy::ResultSet::VERSION = '0.005003';
3use strict;
4use warnings;
5
6use MRO::Compat;
7use Sub::Exporter 'build_exporter';
8use Carp 'croak';
9
10# ABSTRACT: Sugar for your resultsets
11
12sub base { return $_[1] || 'DBIx::Class::ResultSet' }
13
14sub perl_version { return $_[1] }
15
16sub experimental { $_[1] }
17
18sub import {
19   my $self = shift;
20
21   my $inheritor = caller(0);
22   my $args         = $self->parse_arguments(\@_);
23   my $perl_version = $self->perl_version($args->{perl_version});
24   my $experimental = $self->experimental($args->{experimental});
25   my @rest         = @{$args->{rest}};
26
27   $self->set_base($inheritor, $args->{base});
28   $inheritor->load_components(@{$args->{components}});
29
30   @_ = ($self, @rest);
31   my $import = build_exporter({
32      installer  => $self->installer,
33      collectors => [ INIT => $self->gen_INIT($perl_version, $inheritor, $experimental) ],
34   });
35
36   goto $import
37}
38
39sub parse_arguments {
40  my $self = shift;
41  my @args = @{shift @_};
42
43  my $skipnext;
44  my $base;
45  my @rest;
46  my $perl_version = undef;
47  my $components   = [];
48  my $experimental;
49
50  for my $idx ( 0 .. $#args ) {
51    my $val = $args[$idx];
52
53    next unless defined $val;
54    if ($skipnext) {
55      $skipnext--;
56      next;
57    }
58
59    if ( $val eq '-base' ) {
60      $base = $args[$idx + 1];
61      $skipnext = 1;
62    } elsif ( $val eq '-perl5' ) {
63      $perl_version = ord $args[$idx + 1];
64      $skipnext = 1;
65    } elsif ( $val eq '-experimental' ) {
66      $experimental = $args[$idx + 1];
67      $skipnext = 1;
68    } elsif ( $val eq '-components' ) {
69      $components = $args[$idx + 1];
70      $skipnext = 1;
71    } else {
72      push @rest, $val;
73    }
74  }
75
76  return {
77    base         => $base,
78    perl_version => $perl_version,
79    components   => $components,
80    rest         => \@rest,
81    experimental => $experimental,
82  };
83}
84
85sub installer {
86  my ($self) = @_;
87  sub {
88    Sub::Exporter::default_installer @_;
89  }
90}
91
92sub set_base {
93   my ($self, $inheritor, $base) = @_;
94
95   # inlined from parent.pm
96   for ( my @useless = $self->base($base) ) {
97      s{::|'}{/}g;
98      require "$_.pm"; # dies if the file is not found
99   }
100
101   {
102      no strict 'refs';
103      # This is more efficient than push for the new MRO
104      # at least until the new MRO is fixed
105      @{"$inheritor\::ISA"} = (@{"$inheritor\::ISA"} , $self->base($base));
106   }
107}
108
109sub gen_INIT {
110  my ($self, $perl_version, $inheritor, $experimental) = @_;
111  sub {
112    my $orig = $_[1]->{import_args};
113    $_[1]->{import_args} = [];
114
115    strict->import;
116    warnings->import;
117
118    if ($perl_version) {
119       require feature;
120       feature->import(":5.$perl_version")
121    }
122
123    if ($experimental) {
124       require experimental;
125       die 'experimental arg must be an arrayref!'
126          unless ref $experimental && ref $experimental eq 'ARRAY';
127       # to avoid experimental referring to the method
128       experimental::->import(@$experimental)
129    }
130
131    mro::set_mro($inheritor, 'c3');
132
133    1;
134  }
135}
136
1371;
138
139__END__
140
141=pod
142
143=head1 NAME
144
145DBIx::Class::Candy::ResultSet - Sugar for your resultsets
146
147=head1 SYNOPSIS
148
149 package MyApp::Schema::ResultSet::Artist;
150
151 use DBIx::Class::Candy::ResultSet
152   -components => ['Helper::ResultSet::Me'];
153
154 use experimental 'signatures';
155
156 sub by_name ($self, $name) { $self->search({ $self->me . 'name' => $name }) }
157
158 1;
159
160=head1 DESCRIPTION
161
162C<DBIx::Class::Candy::ResultSet> is an initial sugar layer in the spirit of
163L<DBIx::Class::Candy>.  Unlike the original it does not define a DSL, though I
164do have plans for that in the future.  For now all it does is set some imports:
165
166=over
167
168=item *
169
170turns on strict and warnings
171
172=item *
173
174sets your parent class
175
176=item *
177
178sets your mro to C<c3>
179
180=back
181
182=head1 IMPORT OPTIONS
183
184See L</SETTING DEFAULT IMPORT OPTIONS> for information on setting these schema wide.
185
186=head2 -base
187
188 use DBIx::Class::Candy::ResultSet -base => 'MyApp::Schema::ResultSet';
189
190The first thing you can do to customize your usage of C<DBIx::Class::Candy::ResultSet>
191is change the parent class.  Do that by using the C<-base> import option.
192
193=head2 -components
194
195 use DBIx::Class::Candy::ResultSet -components => ['Helper::ResultSet::Me'];
196
197C<DBIx::Class::Candy::ResultSet> allows you to set which components you are using at
198import time.
199
200=head2 -perl5
201
202 use DBIx::Class::Candy::ResultSet -perl5 => v20;
203
204I love the new features in Perl 5.20, so I felt that it would be
205nice to remove the boiler plate of doing C<< use feature ':5.20' >> and
206add it to my sugar importer.  Feel free not to use this.
207
208=head1 SETTING DEFAULT IMPORT OPTIONS
209
210Eventually you will get tired of writing the following in every single one of
211your resultsets:
212
213 use DBIx::Class::Candy::ResultSet
214   -base      => 'MyApp::Schema::ResultSet',
215   -perl5     => v20,
216   -experimental => ['signatures'];
217
218You can set all of these for your whole schema if you define your own C<Candy::ResultSet>
219subclass as follows:
220
221 package MyApp::Schema::Candy::ResultSet;
222
223 use base 'DBIx::Class::Candy::ResultSet';
224
225 sub base { $_[1] || 'MyApp::Schema::ResultSEt' }
226 sub perl_version { 20 }
227 sub experimental { ['signatures'] }
228
229Note the C<< $_[1] || >> in C<base>.  All of these methods are passed the
230values passed in from the arguments to the subclass, so you can either throw
231them away, honor them, die on usage, or whatever.  To be clear, if you define
232your subclass, and someone uses it as follows:
233
234 use MyApp::Schema::Candy::ResultSet
235    -base => 'MyApp::Schema::ResultSet',
236    -perl5 => v18,
237   -experimental => ['postderef'];
238
239Your C<base> method will get C<MyApp::Schema::ResultSet>, your C<experimental>
240will get C<['postderef']>, and your C<perl_version> will get C<18>.
241
242=head1 AUTHOR
243
244Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
245
246=head1 COPYRIGHT AND LICENSE
247
248This software is copyright (c) 2017 by Arthur Axel "fREW" Schmidt.
249
250This is free software; you can redistribute it and/or modify it under
251the same terms as the Perl 5 programming language system itself.
252
253=cut
254