/[A3C]/bin/ldap2model.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Annotation of /bin/ldap2model.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 114 - (hide annotations)
Thu May 15 17:35:45 2008 UTC (12 years, 5 months ago) by dpavlin
File MIME type: text/plain
File size: 5448 byte(s)
since we can't really reliably tell which columns should database
have by just looking into schema, we need to enable users to specify
additional classes to mix them in.

Also generate really nice perl code now, which even works! YAY!
1 dpavlin 98 #!/usr/bin/perl
2     use warnings;
3     use strict;
4    
5 dpavlin 105 =head1 NAME
6 dpavlin 98
7 dpavlin 105 schema2model.pl - convert LDAP schema file into jifty model
8    
9     =head1 DESCRIPTION
10    
11     Create model from ldif data
12    
13     ./bin/ldap2model.pl --model hrEduOrg --path data/all.ldif
14    
15     or directly from LDAP server
16    
17     ./bin/ldap2model.pl --model inetOrgPerson
18     ./bin/ldap2model.pl --model organization
19    
20     which must match C<LDAP.objectClass> in C<etc/conf.yml>
21    
22     With C<--debug> switch all output will go to C<STDOUT>
23     instead to files.
24    
25 dpavlin 114 If your schema for model doesn't include some objectClasses
26     and you want to mixin them manually, use something like:
27    
28     ./bin/ldap2model.pl --model hrEduOrg --mixin dcObject --mixin posixAccount
29    
30 dpavlin 105 =cut
31    
32 dpavlin 103 use lib 'lib';
33    
34     use Jifty;
35     use A3C::LDAP;
36 dpavlin 98 use Net::LDAP::Schema;
37 dpavlin 99 use File::Slurp;
38 dpavlin 98 use Data::Dump qw/dump/;
39 dpavlin 103 use Getopt::Long;
40 dpavlin 98
41 dpavlin 105 my ( $path, $objectClass, $debug );
42 dpavlin 114 my @mixin;
43 dpavlin 98
44 dpavlin 103 GetOptions(
45     'model|objectClass=s', => \$objectClass,
46 dpavlin 114 'mixin=s', => \@mixin,
47 dpavlin 103 'path=s', => \$path,
48 dpavlin 105 'debug+', => \$debug,
49 dpavlin 103 );
50 dpavlin 98
51 dpavlin 103 die "usage: $0 --model netOrgPerson [--path path/to/schema.ldif]\n" unless $objectClass;
52 dpavlin 98
53 dpavlin 103 my $schema;
54     if ( $path ) {
55     $schema = Net::LDAP::Schema->new;
56     $schema->parse ( $path ) or die $schema->error;
57     warn "# loaded schema from $path\n";
58     } else {
59     my $l = A3C::LDAP->new;
60     $schema = $l->ldap->schema;
61     }
62    
63 dpavlin 99 die "$objectClass objectClass not found in $path\n" unless $schema->objectclass( $objectClass );
64    
65     my $model = qq/package A3C::Model::$objectClass;
66     use strict;
67     use warnings;
68    
69     use Jifty::DBI::Schema;
70    
71     use A3C::Record schema {
72    
73     /;
74    
75     my $methods;
76 dpavlin 102 my $create;
77     my $columns;
78 dpavlin 99
79 dpavlin 114 sub model_columns {
80     my $objectClass = shift;
81     my $model;
82     warn "Creating columns for model $objectClass\n";
83 dpavlin 98
84 dpavlin 114 $methods .= qq/\n=head2 $objectClass\n=cut\n\n/;
85 dpavlin 98
86 dpavlin 114 sub entry {
87     my ( $e, $add ) = @_;
88     my $name = $_->{name} || die "no name?";
89     if ( $columns->{$name} ) {
90     warn "WARNING: column $name found again, skipping...\n";
91     return '';
92     }
93     $methods .= qq/sub $_ { \$_[0]->$name }\n/ foreach @{$_->{aliases}};
94     my $out = qq/\tcolumn $name =>\n\t\tlabel is _('$_->{desc}')/;
95     # $out .= qq/,\n\t\t# single-value/ if $_->{'single-value'};
96     # $out .= qq/,\n\t\tfilters are qw(A3C::Filter::Array)/ unless $_->{'single-value'};
97     $out .= qq/,\n\t\tmax_length is $_->{max_length}/ if $_->{'max_length'};
98     $out .= qq/,\n\t\t$add/ if $add;
99     $out .= qq/;\n\n/;
100     $columns->{$name}++;
101     return $out;
102     }
103 dpavlin 98
104 dpavlin 114 $model .= qq/\t# $objectClass super: / . join(' ', $schema->superclass($objectClass)). qq/\n\n/ if $schema->superclass($objectClass);
105 dpavlin 102
106 dpavlin 114 my $must;
107     map {
108     warn "# $objectClass must: ",dump( $_ ),$/ if $debug;
109     $must .= entry( $_, 'is mandatory' );
110     $create->{$_->{name}} = $_->{'single-value'} ? $_->{name} : [ $_->{name}, $_->{desc} ];
111     } $schema->must( $objectClass );
112     $model .= qq/\t# $objectClass must:\n\n$must\n/ if $must;
113 dpavlin 98
114 dpavlin 114 my $may;
115     map {
116     warn "# $objectClass may: ",dump( $_ ),$/ if $debug;
117     $may .= entry( $_ );
118     } $schema->may( $objectClass );
119     $model .= qq/\t# $objectClass may:\n\n$may\n/ if $may;
120 dpavlin 98
121 dpavlin 114 return $model;
122     }
123 dpavlin 98
124 dpavlin 114 $model .= model_columns( $objectClass );
125     $model .= model_columns( $_ ) foreach @mixin;
126 dpavlin 102
127 dpavlin 114 $methods .= qq/\n=head2 name\n\nAuto-generated human readable id for generic access to name\n\n=cut\n\nsub name { \$_[0]->id }\n/ unless $columns->{name};
128    
129 dpavlin 99 $model .= qq/
130    
131     };
132    
133     $methods
134    
135 dpavlin 114 =head ACL
136    
137     We use L<A3C::DefaultACL> for access control
138    
139     =cut
140    
141 dpavlin 99 use A3C::DefaultACL;
142    
143     1;
144     /;
145    
146 dpavlin 105 if ( $debug ) {
147 dpavlin 114 print "##### ----- start of created model $objectClass\n\n$model\n\n#### ---- END of created model $objectClass\n";
148 dpavlin 105 } else {
149     my $model_path = "lib/A3C/Model/$objectClass.pm";
150     write_file( $model_path, $model );
151     print "Created $model_path\n";
152     }
153 dpavlin 102
154     my $test = <<'__END_OF_TEST__';
155     #!/usr/bin/env perl
156     use warnings;
157     use strict;
158    
159     =head1 DESCRIPTION
160    
161     A basic test harness for the _objectClass_ model.
162    
163     =cut
164    
165     use Jifty::Test tests => 11;
166    
167     # Make sure we can load the model
168     use_ok('A3C::Model::_objectClass_');
169    
170     # Grab a system user
171     my $system_user = A3C::CurrentUser->superuser;
172     ok($system_user, "Found a system user");
173    
174     # Try testing a create
175     my $o = A3C::Model::_objectClass_->new(current_user => $system_user);
176     my ($id) = $o->create(
177     _create_1_);
178     ok($id, "_objectClass_ create returned success");
179     ok($o->id, "New _objectClass_ has valid id set");
180     is($o->id, $id, "Create returned the right id");
181    
182     # And another
183     $o->create(
184     _create_2_);
185     ok($o->id, "_objectClass_ create returned another value");
186     isnt($o->id, $id, "And it is different from the previous one");
187    
188     # Searches in general
189     my $collection = A3C::Model::_objectClass_Collection->new(current_user => $system_user);
190     $collection->unlimit;
191     is($collection->count, 2, "Finds two records");
192    
193     # Searches in specific
194     $collection->limit(column => 'id', value => $o->id);
195     is($collection->count, 1, "Finds one record with specific id");
196    
197     # Delete one of them
198     $o->delete;
199     $collection->redo_search;
200     is($collection->count, 0, "Deleted row is gone");
201    
202     # And the other one is still there
203     $collection->unlimit;
204     is($collection->count, 1, "Still one left");
205     __END_OF_TEST__
206    
207     $test =~ s/_objectClass_/$objectClass/gs;
208    
209     foreach my $round ( 1 .. 2 ) {
210     my $data;
211 dpavlin 108 $data .= qq/\t\t'$_' => / . dump( $create->{$_} ) . qq/,\n/ foreach keys %$create;
212 dpavlin 105 warn "$round data = $data\n" if $debug;
213 dpavlin 102 $test =~ s/_create_${round}_/$data/gs;
214     }
215    
216 dpavlin 105 if ( $debug ) {
217     print "##### ----- template test\n$test\n";
218     } else {
219     my $test_path = "t/00-model-$objectClass.t";
220     write_file( $test_path, $test );
221     print "Created $test_path\n";
222     chmod 0755, $test_path;
223     }

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26