[111] | 1 | package LATMOS::Accounts::Web::Model::AttrForms; |
---|
| 2 | |
---|
| 3 | use strict; |
---|
| 4 | use warnings; |
---|
| 5 | use base 'Catalyst::Model'; |
---|
[861] | 6 | use LATMOS::Accounts::Log; |
---|
[955] | 7 | use HTML::Prototype; |
---|
[111] | 8 | |
---|
| 9 | =head1 NAME |
---|
| 10 | |
---|
| 11 | LATMOS::Accounts::Web::Model::AttrForms - Catalyst Model |
---|
| 12 | |
---|
| 13 | =head1 DESCRIPTION |
---|
| 14 | |
---|
| 15 | Catalyst Model. |
---|
| 16 | |
---|
| 17 | =cut |
---|
| 18 | |
---|
| 19 | my $forms = { |
---|
[894] | 20 | usersys => { |
---|
[117] | 21 | name => 'SystÚme', |
---|
[112] | 22 | attrs => [ qw( |
---|
[125] | 23 | sn givenName description |
---|
[1282] | 24 | comment |
---|
[125] | 25 | uid uidNumber gidNumber gecos homeDirectory loginShell |
---|
[670] | 26 | mail initials nickname |
---|
[894] | 27 | expire |
---|
[1348] | 28 | endcircuit |
---|
[677] | 29 | locked |
---|
[1349] | 30 | services |
---|
[677] | 31 | create |
---|
| 32 | date |
---|
[112] | 33 | ) ], |
---|
[117] | 34 | }, |
---|
[894] | 35 | user => { |
---|
[1264] | 36 | name => 'Statut RH', |
---|
[129] | 37 | attrs => [ qw( |
---|
[894] | 38 | sn givenName description |
---|
[1291] | 39 | comment |
---|
[129] | 40 | company |
---|
[733] | 41 | department |
---|
[1365] | 42 | managerContact |
---|
[151] | 43 | manager |
---|
[431] | 44 | contratType |
---|
[160] | 45 | expire |
---|
[1348] | 46 | endcircuit |
---|
[894] | 47 | snNative |
---|
| 48 | givenNameNative |
---|
| 49 | wWWHomePage |
---|
| 50 | halReference |
---|
| 51 | create |
---|
| 52 | date |
---|
[129] | 53 | ) ], |
---|
| 54 | }, |
---|
[894] | 55 | useraddress => { |
---|
| 56 | name => 'Adresse', |
---|
| 57 | attrs => [ qw( |
---|
| 58 | initials |
---|
| 59 | mail |
---|
| 60 | ) ], |
---|
| 61 | }, |
---|
[861] | 62 | usermy => { |
---|
| 63 | name => 'My', |
---|
| 64 | attrs => [ qw( |
---|
| 65 | snNative |
---|
| 66 | givenNameNative |
---|
| 67 | wWWHomePage |
---|
| 68 | halReference |
---|
| 69 | ) ], |
---|
| 70 | }, |
---|
[134] | 71 | site => { |
---|
| 72 | name => 'Site', |
---|
| 73 | attrs => [ qw( |
---|
[148] | 74 | description |
---|
[861] | 75 | siteNick |
---|
[134] | 76 | streetAddress |
---|
| 77 | postOfficeBox |
---|
| 78 | postalCode |
---|
[364] | 79 | l |
---|
[160] | 80 | st |
---|
[364] | 81 | co |
---|
[448] | 82 | facsimileTelephoneNumber |
---|
[740] | 83 | create |
---|
| 84 | date |
---|
[364] | 85 | ) ], |
---|
| 86 | }, |
---|
| 87 | address => { |
---|
| 88 | name => 'Adresse', |
---|
| 89 | attrs => [ qw( |
---|
| 90 | isMainAddress |
---|
| 91 | telephoneNumber |
---|
| 92 | streetAddress |
---|
| 93 | postOfficeBox |
---|
| 94 | postalCode |
---|
[134] | 95 | l |
---|
[364] | 96 | st |
---|
| 97 | physicalDeliveryOfficeName |
---|
| 98 | site |
---|
| 99 | co |
---|
[861] | 100 | unexported |
---|
[714] | 101 | description |
---|
[1329] | 102 | facsimileTelephoneNumber |
---|
[134] | 103 | ) ], |
---|
| 104 | }, |
---|
[125] | 105 | group => { |
---|
| 106 | name => 'SystÚme', |
---|
| 107 | attrs => [ qw( |
---|
[1255] | 108 | gidNumber |
---|
| 109 | description label |
---|
[1282] | 110 | comment |
---|
[183] | 111 | managedBy |
---|
[1186] | 112 | managedAlsoBy |
---|
[1137] | 113 | autoMemberFilter |
---|
[861] | 114 | sutype |
---|
[1349] | 115 | services |
---|
[740] | 116 | create |
---|
| 117 | date |
---|
[125] | 118 | ) ], |
---|
| 119 | }, |
---|
[861] | 120 | nethost => { |
---|
| 121 | name => 'Ordinateur', |
---|
| 122 | attrs => [ qw( |
---|
| 123 | name |
---|
| 124 | description |
---|
[1282] | 125 | comment |
---|
[1302] | 126 | related |
---|
[861] | 127 | serialNumber |
---|
[1237] | 128 | encryptKey |
---|
[861] | 129 | owner |
---|
[924] | 130 | user |
---|
[861] | 131 | ip |
---|
| 132 | macaddr |
---|
[1064] | 133 | puppetClass |
---|
[1087] | 134 | noInheritPuppet |
---|
[861] | 135 | noDynamic |
---|
[1349] | 136 | services |
---|
[861] | 137 | cname |
---|
| 138 | otherName |
---|
| 139 | reverse |
---|
| 140 | create |
---|
| 141 | date |
---|
| 142 | unexported |
---|
[1225] | 143 | sshfp |
---|
[861] | 144 | ) ], |
---|
| 145 | }, |
---|
| 146 | netzone => { |
---|
| 147 | name => 'Zone réseau', |
---|
| 148 | attrs => [ qw( |
---|
| 149 | name |
---|
| 150 | description |
---|
| 151 | type |
---|
| 152 | net |
---|
| 153 | netExclude |
---|
[1064] | 154 | puppetClass |
---|
[861] | 155 | outputD |
---|
| 156 | templateD |
---|
| 157 | site |
---|
| 158 | allow_dyn |
---|
| 159 | dynFrom |
---|
| 160 | domain |
---|
| 161 | ipCount |
---|
| 162 | freeIPCount |
---|
| 163 | create |
---|
| 164 | date |
---|
| 165 | dnsRevision |
---|
| 166 | lastUpdate |
---|
| 167 | unexported |
---|
| 168 | ) ], |
---|
| 169 | }, |
---|
[929] | 170 | aliases => { |
---|
| 171 | name => 'Alias mail', |
---|
| 172 | attrs => [ qw( |
---|
| 173 | forward |
---|
[939] | 174 | expire |
---|
[1281] | 175 | description |
---|
[1282] | 176 | comment |
---|
[929] | 177 | finalpoint |
---|
| 178 | parents |
---|
[1305] | 179 | create |
---|
[929] | 180 | date |
---|
| 181 | unexported |
---|
| 182 | )], |
---|
| 183 | }, |
---|
[1305] | 184 | services => { |
---|
| 185 | name => 'Services', |
---|
| 186 | attrs => [ qw( |
---|
[1346] | 187 | type |
---|
[1305] | 188 | description |
---|
| 189 | comment |
---|
[1346] | 190 | start |
---|
| 191 | end |
---|
[1305] | 192 | manager |
---|
| 193 | dependOn |
---|
| 194 | create |
---|
| 195 | date |
---|
| 196 | unexported |
---|
| 197 | )], |
---|
| 198 | }, |
---|
[111] | 199 | }; |
---|
| 200 | |
---|
[116] | 201 | sub escape { |
---|
| 202 | my ($self, $text) = @_; |
---|
[117] | 203 | $text ||= ''; |
---|
[116] | 204 | for ($text) { |
---|
| 205 | s/&/&/g; |
---|
| 206 | s/</</g; |
---|
| 207 | s/>/>/g; |
---|
| 208 | s/"/"/g; |
---|
| 209 | } |
---|
| 210 | $text; |
---|
| 211 | } |
---|
[111] | 212 | |
---|
| 213 | sub new { |
---|
| 214 | my ($class) = @_; |
---|
| 215 | bless({}, $class); |
---|
| 216 | } |
---|
| 217 | |
---|
[144] | 218 | # call either OBJ or type + base |
---|
| 219 | |
---|
[111] | 220 | sub ACCEPT_CONTEXT { |
---|
[144] | 221 | my ($self, $c, $form, $object, $base) = @_; |
---|
| 222 | my $new = {}; |
---|
| 223 | $new->{c} = $c; |
---|
| 224 | $new->{form} = $form; |
---|
| 225 | $new->{object} = $object if (ref $object); |
---|
[1190] | 226 | $new->{base} = $base || (ref $object ? $object->base : undef) or return $self; |
---|
[144] | 227 | $new->{otype} = ref $object ? $object->type : $object; |
---|
[1329] | 228 | |
---|
| 229 | |
---|
| 230 | foreach (@{ $forms->{$form}->{attrs} }) { |
---|
| 231 | $new->{_attr}{$_} = $c->model('AttrFormsA', $_, ($object |
---|
| 232 | ? ($object) |
---|
| 233 | : ($base, $new->{otype}))) |
---|
| 234 | or die "Cannot get attribute $_"; |
---|
| 235 | } |
---|
| 236 | |
---|
[927] | 237 | bless($new, __PACKAGE__); |
---|
[111] | 238 | } |
---|
| 239 | |
---|
[144] | 240 | sub base { |
---|
| 241 | my ( $self ) = @_; |
---|
| 242 | $self->{base} |
---|
| 243 | } |
---|
| 244 | |
---|
| 245 | sub otype { |
---|
| 246 | my ($self) = @_; |
---|
| 247 | $self->{otype}; |
---|
| 248 | } |
---|
| 249 | |
---|
[1333] | 250 | sub object { |
---|
| 251 | my ($self) = @_; |
---|
| 252 | $self->{object}; |
---|
| 253 | } |
---|
| 254 | |
---|
[117] | 255 | sub label { |
---|
| 256 | my ($self) = @_; |
---|
| 257 | $forms->{$self->{form}}->{name} || '' |
---|
| 258 | } |
---|
| 259 | |
---|
[111] | 260 | sub attributes { |
---|
[373] | 261 | my ($self, $for) = @_; |
---|
[507] | 262 | grep { $_ } |
---|
[861] | 263 | grep { $self->base->attribute($self->otype, $_) } |
---|
[143] | 264 | @{ $forms->{$self->{form}}->{attrs} }; |
---|
[111] | 265 | } |
---|
| 266 | |
---|
[955] | 267 | sub _uri_part { |
---|
| 268 | my ($self, $ref) = @_; |
---|
| 269 | my $uri_part = { |
---|
| 270 | user => 'users', |
---|
| 271 | group => 'groups', |
---|
| 272 | nethost => 'nethosts', |
---|
| 273 | netzone => 'netzones', |
---|
[1080] | 274 | site => 'sites', |
---|
| 275 | aliasess => 'aliases', |
---|
[955] | 276 | }->{$ref}; |
---|
| 277 | } |
---|
| 278 | |
---|
[1329] | 279 | sub attr_label { |
---|
| 280 | my ($self, $attr, $label, $hint) = @_; |
---|
[955] | 281 | |
---|
[1329] | 282 | if ($label) { |
---|
| 283 | return $label; |
---|
| 284 | } elsif (my $hash = LATMOS::Accounts::Web->config->{attrs}{$attr}) { |
---|
| 285 | return $hash->{label}; |
---|
| 286 | } else { |
---|
[1331] | 287 | return $attr; |
---|
[1329] | 288 | } |
---|
| 289 | } |
---|
[955] | 290 | |
---|
[1329] | 291 | sub attr_hint { |
---|
| 292 | my ($self, $attr) = @_; |
---|
[861] | 293 | |
---|
[1329] | 294 | $self->{_attr}{$attr}->attr_hint; |
---|
[953] | 295 | } |
---|
[951] | 296 | |
---|
[953] | 297 | sub attr_field { |
---|
| 298 | my ($self, $attr, $type) = @_; |
---|
| 299 | |
---|
[1329] | 300 | $self->{_attr}{$attr}->attr_field($type); |
---|
[111] | 301 | } |
---|
| 302 | |
---|
[1333] | 303 | sub field { |
---|
| 304 | my ($self, $attr, $type) = @_; |
---|
[174] | 305 | |
---|
[1333] | 306 | if (!$self->{_attr}{$attr}) { |
---|
| 307 | $self->{_attr}{$attr} = $self->{c}->model('AttrFormsA', $attr, ($self->object |
---|
| 308 | ? ($self->object) |
---|
| 309 | : ($self->base, $self->otype))) |
---|
| 310 | or die "Cannot get attribute $_"; |
---|
| 311 | } |
---|
| 312 | |
---|
| 313 | $self->{_attr}{$attr}; |
---|
| 314 | } |
---|
| 315 | |
---|
| 316 | |
---|
[861] | 317 | sub write_attributes { |
---|
| 318 | my ($self) = @_; |
---|
| 319 | my @attrs; |
---|
[1329] | 320 | foreach (values %{ $self->{_attr} }) { |
---|
| 321 | $_->readonly and next; |
---|
[861] | 322 | push(@attrs, $_); |
---|
| 323 | } |
---|
| 324 | @attrs; |
---|
| 325 | } |
---|
| 326 | |
---|
[112] | 327 | sub set_attrs { |
---|
[927] | 328 | my ($self, $attrs) = @_; |
---|
| 329 | $self->{c}->req->param($self->label) || $attrs or return; |
---|
[738] | 330 | my %fields; |
---|
[927] | 331 | foreach ($attrs ? @{ $attrs } : $self->write_attributes) { |
---|
[1329] | 332 | my $attr = ref $_ ? $_ : $self->{_attr}{$_}; |
---|
[899] | 333 | if ($attr->{multiple}) { |
---|
[1329] | 334 | $fields{$attr->name} = [ grep { $_ } $self->{c}->req->param($attr->htmlname) ]; |
---|
[738] | 335 | } else { |
---|
[1329] | 336 | $fields{$attr->name} = $self->{c}->req->param($attr->htmlname); |
---|
[738] | 337 | } |
---|
| 338 | } |
---|
[861] | 339 | $self->{object}->set_c_fields(%fields) or do { |
---|
| 340 | $self->{c}->stash->{page}{error} = |
---|
| 341 | LATMOS::Accounts::Log::lastmessage(LA_ERR); |
---|
| 342 | $self->{object}->base->rollback; |
---|
| 343 | return; |
---|
| 344 | }; |
---|
[112] | 345 | $self->{object}->base->commit; |
---|
| 346 | } |
---|
| 347 | |
---|
[1329] | 348 | sub submit { |
---|
| 349 | my ($self) = @_; |
---|
| 350 | return sprintf( |
---|
| 351 | '<input type="submit" name="%s" value="Enregistrer">', |
---|
| 352 | $self->escape($self->label), |
---|
| 353 | ); |
---|
| 354 | } |
---|
| 355 | |
---|
| 356 | |
---|
[111] | 357 | =head1 AUTHOR |
---|
| 358 | |
---|
| 359 | Thauvin Olivier |
---|
| 360 | |
---|
| 361 | =head1 LICENSE |
---|
| 362 | |
---|
| 363 | This library is free software, you can redistribute it and/or modify |
---|
| 364 | it under the same terms as Perl itself. |
---|
| 365 | |
---|
| 366 | =cut |
---|
| 367 | |
---|
| 368 | 1; |
---|