/[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 108 - (hide annotations)
Fri May 2 14:38:45 2008 UTC (12 years, 5 months ago) by dpavlin
File MIME type: text/plain
File size: 4549 byte(s)
- don't insert single-value comment (corrupts model)
- comment out filter for arrays (doesn't work yet)
- create array of values for test data (which get squashed into scalar by Jifty currently)
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 108 # $out .= qq/,\n\t\t# single-value/ if $_->{'single-value'};
78     # $out .= qq/,\n\t\tfilters are qw(A3C::Filter::Array)/ unless $_->{'single-value'};
79 dpavlin 98 $out .= qq/,\n\t\tmax_length is $_->{max_length}/ if $_->{'max_length'};
80     $out .= qq/,\n\t\t$add/ if $add;
81     $out .= qq/;\n\n/;
82 dpavlin 102 $columns->{$name}++;
83 dpavlin 98 return $out;
84     }
85    
86 dpavlin 99 $model .= qq/\t# $objectClass super: / . join(' ', $schema->superclass($objectClass)). qq/\n\n/ if $schema->superclass($objectClass);
87 dpavlin 98
88     $model .= qq/\t# $objectClass must:\n\n/;
89    
90 dpavlin 102
91 dpavlin 98 map {
92 dpavlin 105 warn "# $objectClass must: ",dump( $_ ) if $debug;
93 dpavlin 98 $model .= entry( $_, 'is mandatory' );
94 dpavlin 108 $create->{$_->{name}} = $_->{'single-value'} ? $_->{name} : [ $_->{name}, $_->{desc} ];
95 dpavlin 98 } $schema->must( $objectClass );
96    
97     $model .= qq/\t# $objectClass may:\n\n/;
98    
99     map {
100 dpavlin 105 warn "# $objectClass may: ",dump( $_ ) if $debug;
101 dpavlin 98 $model .= entry( $_ );
102     } $schema->may( $objectClass );
103    
104 dpavlin 102 $methods .= qq/sub name { \$_[0]->id }\n/ unless $columns->{name};
105    
106 dpavlin 99 $model .= qq/
107    
108     };
109    
110     $methods
111    
112     use A3C::DefaultACL;
113    
114     1;
115     /;
116    
117 dpavlin 105 if ( $debug ) {
118     print "##### ----- created model test\n$model\n";
119     } else {
120     my $model_path = "lib/A3C/Model/$objectClass.pm";
121     write_file( $model_path, $model );
122     print "Created $model_path\n";
123     }
124 dpavlin 102
125     my $test = <<'__END_OF_TEST__';
126     #!/usr/bin/env perl
127     use warnings;
128     use strict;
129    
130     =head1 DESCRIPTION
131    
132     A basic test harness for the _objectClass_ model.
133    
134     =cut
135    
136     use Jifty::Test tests => 11;
137    
138     # Make sure we can load the model
139     use_ok('A3C::Model::_objectClass_');
140    
141     # Grab a system user
142     my $system_user = A3C::CurrentUser->superuser;
143     ok($system_user, "Found a system user");
144    
145     # Try testing a create
146     my $o = A3C::Model::_objectClass_->new(current_user => $system_user);
147     my ($id) = $o->create(
148     _create_1_);
149     ok($id, "_objectClass_ create returned success");
150     ok($o->id, "New _objectClass_ has valid id set");
151     is($o->id, $id, "Create returned the right id");
152    
153     # And another
154     $o->create(
155     _create_2_);
156     ok($o->id, "_objectClass_ create returned another value");
157     isnt($o->id, $id, "And it is different from the previous one");
158    
159     # Searches in general
160     my $collection = A3C::Model::_objectClass_Collection->new(current_user => $system_user);
161     $collection->unlimit;
162     is($collection->count, 2, "Finds two records");
163    
164     # Searches in specific
165     $collection->limit(column => 'id', value => $o->id);
166     is($collection->count, 1, "Finds one record with specific id");
167    
168     # Delete one of them
169     $o->delete;
170     $collection->redo_search;
171     is($collection->count, 0, "Deleted row is gone");
172    
173     # And the other one is still there
174     $collection->unlimit;
175     is($collection->count, 1, "Still one left");
176     __END_OF_TEST__
177    
178     $test =~ s/_objectClass_/$objectClass/gs;
179    
180     foreach my $round ( 1 .. 2 ) {
181     my $data;
182 dpavlin 108 $data .= qq/\t\t'$_' => / . dump( $create->{$_} ) . qq/,\n/ foreach keys %$create;
183 dpavlin 105 warn "$round data = $data\n" if $debug;
184 dpavlin 102 $test =~ s/_create_${round}_/$data/gs;
185     }
186    
187 dpavlin 105 if ( $debug ) {
188     print "##### ----- template test\n$test\n";
189     } else {
190     my $test_path = "t/00-model-$objectClass.t";
191     write_file( $test_path, $test );
192     print "Created $test_path\n";
193     chmod 0755, $test_path;
194     }

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26