/[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 117 - (hide annotations)
Thu May 15 18:33:58 2008 UTC (15 years, 10 months ago) by dpavlin
File MIME type: text/plain
File size: 5506 byte(s)
make pod pass test :-)
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 117 my $aliases = qq/\n=head1 $objectClass helper methods\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 dpavlin 117 $aliases .= qq/sub $_ { \$_[0]->$name }\n/ foreach @{$_->{aliases}};
94 dpavlin 114 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 117 $methods .= $aliases unless $aliases;
122    
123 dpavlin 114 return $model;
124     }
125 dpavlin 98
126 dpavlin 114 $model .= model_columns( $objectClass );
127     $model .= model_columns( $_ ) foreach @mixin;
128 dpavlin 102
129 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};
130    
131 dpavlin 99 $model .= qq/
132    
133     };
134    
135     $methods
136    
137 dpavlin 117 =head2 ACL
138 dpavlin 114
139     We use L<A3C::DefaultACL> for access control
140    
141     =cut
142    
143 dpavlin 99 use A3C::DefaultACL;
144    
145     1;
146     /;
147    
148 dpavlin 105 if ( $debug ) {
149 dpavlin 114 print "##### ----- start of created model $objectClass\n\n$model\n\n#### ---- END of created model $objectClass\n";
150 dpavlin 105 } else {
151     my $model_path = "lib/A3C/Model/$objectClass.pm";
152     write_file( $model_path, $model );
153     print "Created $model_path\n";
154     }
155 dpavlin 102
156     my $test = <<'__END_OF_TEST__';
157     #!/usr/bin/env perl
158     use warnings;
159     use strict;
160    
161     =head1 DESCRIPTION
162    
163     A basic test harness for the _objectClass_ model.
164    
165     =cut
166    
167     use Jifty::Test tests => 11;
168    
169     # Make sure we can load the model
170     use_ok('A3C::Model::_objectClass_');
171    
172     # Grab a system user
173     my $system_user = A3C::CurrentUser->superuser;
174     ok($system_user, "Found a system user");
175    
176     # Try testing a create
177     my $o = A3C::Model::_objectClass_->new(current_user => $system_user);
178     my ($id) = $o->create(
179     _create_1_);
180     ok($id, "_objectClass_ create returned success");
181     ok($o->id, "New _objectClass_ has valid id set");
182     is($o->id, $id, "Create returned the right id");
183    
184     # And another
185     $o->create(
186     _create_2_);
187     ok($o->id, "_objectClass_ create returned another value");
188     isnt($o->id, $id, "And it is different from the previous one");
189    
190     # Searches in general
191     my $collection = A3C::Model::_objectClass_Collection->new(current_user => $system_user);
192     $collection->unlimit;
193     is($collection->count, 2, "Finds two records");
194    
195     # Searches in specific
196     $collection->limit(column => 'id', value => $o->id);
197     is($collection->count, 1, "Finds one record with specific id");
198    
199     # Delete one of them
200     $o->delete;
201     $collection->redo_search;
202     is($collection->count, 0, "Deleted row is gone");
203    
204     # And the other one is still there
205     $collection->unlimit;
206     is($collection->count, 1, "Still one left");
207     __END_OF_TEST__
208    
209     $test =~ s/_objectClass_/$objectClass/gs;
210    
211     foreach my $round ( 1 .. 2 ) {
212     my $data;
213 dpavlin 108 $data .= qq/\t\t'$_' => / . dump( $create->{$_} ) . qq/,\n/ foreach keys %$create;
214 dpavlin 105 warn "$round data = $data\n" if $debug;
215 dpavlin 102 $test =~ s/_create_${round}_/$data/gs;
216     }
217    
218 dpavlin 105 if ( $debug ) {
219     print "##### ----- template test\n$test\n";
220     } else {
221     my $test_path = "t/00-model-$objectClass.t";
222     write_file( $test_path, $test );
223     print "Created $test_path\n";
224     chmod 0755, $test_path;
225     }

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26