/[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 105 - (hide annotations)
Thu May 1 16:31:00 2008 UTC (12 years, 5 months ago) by dpavlin
File MIME type: text/plain
File size: 4391 byte(s)
added pod usage, debug won't touch filesystem any more
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     =cut
26    
27 dpavlin 103 use lib 'lib';
28    
29     use Jifty;
30     use A3C::LDAP;
31 dpavlin 98 use Net::LDAP::Schema;
32 dpavlin 99 use File::Slurp;
33 dpavlin 98 use Data::Dump qw/dump/;
34 dpavlin 103 use Getopt::Long;
35 dpavlin 98
36 dpavlin 105 my ( $path, $objectClass, $debug );
37 dpavlin 98
38 dpavlin 103 GetOptions(
39     'model|objectClass=s', => \$objectClass,
40     'path=s', => \$path,
41 dpavlin 105 'debug+', => \$debug,
42 dpavlin 103 );
43 dpavlin 98
44 dpavlin 103 die "usage: $0 --model netOrgPerson [--path path/to/schema.ldif]\n" unless $objectClass;
45 dpavlin 98
46 dpavlin 103 my $schema;
47     if ( $path ) {
48     $schema = Net::LDAP::Schema->new;
49     $schema->parse ( $path ) or die $schema->error;
50     warn "# loaded schema from $path\n";
51     } else {
52     my $l = A3C::LDAP->new;
53     $schema = $l->ldap->schema;
54     }
55    
56 dpavlin 99 die "$objectClass objectClass not found in $path\n" unless $schema->objectclass( $objectClass );
57    
58     my $model = qq/package A3C::Model::$objectClass;
59     use strict;
60     use warnings;
61    
62     use Jifty::DBI::Schema;
63    
64     use A3C::Record schema {
65    
66     /;
67    
68     my $methods;
69 dpavlin 102 my $create;
70     my $columns;
71 dpavlin 99
72 dpavlin 98 sub entry {
73     my ( $e, $add ) = @_;
74 dpavlin 99 my $name = $_->{name} || die "no name?";
75     $methods .= qq/sub $_ { \$_[0]->$name }\n/ foreach @{$_->{aliases}};
76     my $out = qq/\tcolumn $name =>\n\t\tlabel is _('$_->{desc}')/;
77 dpavlin 98 $out .= qq/,\n\t\t# single-value/ if $_->{'single-value'};
78     $out .= qq/,\n\t\tmax_length is $_->{max_length}/ if $_->{'max_length'};
79     $out .= qq/,\n\t\t$add/ if $add;
80     $out .= qq/;\n\n/;
81 dpavlin 102 $columns->{$name}++;
82 dpavlin 98 return $out;
83     }
84    
85 dpavlin 99 $model .= qq/\t# $objectClass super: / . join(' ', $schema->superclass($objectClass)). qq/\n\n/ if $schema->superclass($objectClass);
86 dpavlin 98
87     $model .= qq/\t# $objectClass must:\n\n/;
88    
89 dpavlin 102
90 dpavlin 98 map {
91 dpavlin 105 warn "# $objectClass must: ",dump( $_ ) if $debug;
92 dpavlin 98 $model .= entry( $_, 'is mandatory' );
93 dpavlin 102 $create->{$_->{name}} = $_->{name};
94 dpavlin 98 } $schema->must( $objectClass );
95    
96     $model .= qq/\t# $objectClass may:\n\n/;
97    
98     map {
99 dpavlin 105 warn "# $objectClass may: ",dump( $_ ) if $debug;
100 dpavlin 98 $model .= entry( $_ );
101     } $schema->may( $objectClass );
102    
103 dpavlin 102 $methods .= qq/sub name { \$_[0]->id }\n/ unless $columns->{name};
104    
105 dpavlin 99 $model .= qq/
106    
107     };
108    
109     $methods
110    
111     use A3C::DefaultACL;
112    
113     1;
114     /;
115    
116 dpavlin 105 if ( $debug ) {
117     print "##### ----- created model test\n$model\n";
118     } else {
119     my $model_path = "lib/A3C/Model/$objectClass.pm";
120     write_file( $model_path, $model );
121     print "Created $model_path\n";
122     }
123 dpavlin 102
124     my $test = <<'__END_OF_TEST__';
125     #!/usr/bin/env perl
126     use warnings;
127     use strict;
128    
129     =head1 DESCRIPTION
130    
131     A basic test harness for the _objectClass_ model.
132    
133     =cut
134    
135     use Jifty::Test tests => 11;
136    
137     # Make sure we can load the model
138     use_ok('A3C::Model::_objectClass_');
139    
140     # Grab a system user
141     my $system_user = A3C::CurrentUser->superuser;
142     ok($system_user, "Found a system user");
143    
144     # Try testing a create
145     my $o = A3C::Model::_objectClass_->new(current_user => $system_user);
146     my ($id) = $o->create(
147     _create_1_);
148     ok($id, "_objectClass_ create returned success");
149     ok($o->id, "New _objectClass_ has valid id set");
150     is($o->id, $id, "Create returned the right id");
151    
152     # And another
153     $o->create(
154     _create_2_);
155     ok($o->id, "_objectClass_ create returned another value");
156     isnt($o->id, $id, "And it is different from the previous one");
157    
158     # Searches in general
159     my $collection = A3C::Model::_objectClass_Collection->new(current_user => $system_user);
160     $collection->unlimit;
161     is($collection->count, 2, "Finds two records");
162    
163     # Searches in specific
164     $collection->limit(column => 'id', value => $o->id);
165     is($collection->count, 1, "Finds one record with specific id");
166    
167     # Delete one of them
168     $o->delete;
169     $collection->redo_search;
170     is($collection->count, 0, "Deleted row is gone");
171    
172     # And the other one is still there
173     $collection->unlimit;
174     is($collection->count, 1, "Still one left");
175     __END_OF_TEST__
176    
177     $test =~ s/_objectClass_/$objectClass/gs;
178    
179     foreach my $round ( 1 .. 2 ) {
180     my $data;
181     $data .= qq/\t\t'$_' => '$_ $round',\n/ foreach keys %$create;
182 dpavlin 105 warn "$round data = $data\n" if $debug;
183 dpavlin 102 $test =~ s/_create_${round}_/$data/gs;
184     }
185    
186 dpavlin 105 if ( $debug ) {
187     print "##### ----- template test\n$test\n";
188     } else {
189     my $test_path = "t/00-model-$objectClass.t";
190     write_file( $test_path, $test );
191     print "Created $test_path\n";
192     chmod 0755, $test_path;
193     }

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26