1package Bigtop::Backend::Control::Gantry; 2use strict; use warnings; 3 4# I apologize to all developers for littering the top of this file with POD. 5# If I don't the first POD that perldoc shows is the POD template for generated 6# code. Try vim folding. 7 8=head1 NAME 9 10Bigtop::Backend::Control::Gantry - controller generator for the Gantry framework 11 12=head1 SYNOPSIS 13 14Build a file like this called my.bigtop: 15 16 config { 17 base_dir `/home/username`; 18 Control Gantry {} 19 } 20 app App::Name { 21 controller SomeController {} 22 } 23 24Then run this command: 25 26 bigtop my.bigtop Control 27 28=head1 DESCRIPTION 29 30When your bigtop config includes Control Gantry, this module will be 31loaded by Bigtop::Parser when bigtop is run with all or Control 32in its build list. 33 34This module builds files in the lib subdirectory of base_dir/App-Name. 35(But you can change name by supplying app_dir, as explained in 36Bigtop::Parser's pod.) 37 38There will generally be two files for each controller you define. One 39will have the name you give it with the app name in front. For the SYNOPSIS 40example, that file will be called 41 42 /home/username/App-Name/lib/App/Name/SomeController.pm 43 44I call this file the stub. It won't have much useful code in it, though 45it might have method stubs depending on what's in its controller block. 46 47The other file will have generated code in it. As such it will go in the 48GEN subdirectory of the directory where the stub lives. In the example, 49the name will be: 50 51 /home/username/App-Name/lib/App/Name/GEN/SomeController.pm 52 53During the intial build, both of these files will be made. Subsequently, 54the stub will not be regenerated (unless you delete it), but the GEN file 55will be. To prevent regeneration you may either put no_gen in the 56Control Gantry block of the config, like this: 57 58 config { 59 ... 60 Control Gantry { no_gen 1; } 61 } 62 63or you may mark the controller itself: 64 65 controller SomeController { 66 no_gen 1; 67 } 68 69=head2 controller KEYWORDS 70 71Each controller has the form 72 73 controller name is type { 74 keyword arg, list; 75 method name is type { 76 keyword arg, list; 77 } 78 } 79 80For a list of the keywords you can include in the controller block see the pod 81for Bigtop::Control. For a list of the keywords you can include in the 82method block, see below (and note that most of these vary by the method's 83type). 84 85The controller phrase 'is type' is optional and defaults to 'is stub' which 86has no effect. The supported types are: 87 88=over 4 89 90=item AutoCRUD 91 92This simply adds Gantry::Plugins::AutoCRUD to your uses list (it 93will create the list if you don't have one). Do not manually put 94Gantry::Plugins::AutoCRUD in the uses list if you use type AutoCRUD, or 95it will have two use statements. 96 97=item CRUD 98 99This adds Gantry::Plugins::CRUD to your uses list (it will create the list 100if you don't have one). As with AutoCRUD, don't manually put 101Gantry::Plugins::CRUD in your uses list if you set the type to CRUD. 102 103In addition to modifying your uses list, this type will make extra code. 104Each time it sees a method of type AutoCRUD_form, it will make the following 105things (suppose the AutoCRUD_form method is called my_crud_form): 106 107=over 4 108 109=item form method 110 111This method will be suitable for use as the form named parameter to the 112Gantry::Plugins::CRUD constructor. 113 114You get this whether you set the controller type to CRUD or not. 115 116=item constructed crud object 117 118 my $my_crud = Gantry::Plugins::CRUD->new( 119 add_action => \&my_crud_add, 120 edit_action => \&my_crud_edit, 121 delete_action => \&my_crud_delete, 122 form => \&my_crud_form, 123 redirect => \&my_crud_redirect, 124 text_descr => 'your text_description here', 125 ); 126 127=item redirect method 128 129Replicates the default behavior of always sending the user back to 130$self->location on successful save or cancel. 131 132=item do_* methods 133 134A set of methods for add, edit, and delete which Gantry's handler will call. 135These are stubs. Example: 136 137 #------------------------------------------------- 138 # $self->do_add( ) 139 #------------------------------------------------- 140 sub do_add { 141 my $self = shift; 142 143 $crud->add( $self, { data => \@_ } ); 144 } 145 146Note that you should do something better with the data. This method 147leaves you having to fish through an array in the action method, and 148therefore makes it harder for code readers to find out what is in the data. 149 150=item action methods 151 152A set of methods corresponding to do_add, do_edit, and do_delete which 153are specified during the construction of the crud object. Example: 154 155 #------------------------------------------------- 156 # $self->my_crud_add( $id ) 157 #------------------------------------------------- 158 sub my_crud_add { 159 my ( $self, $params, $data ) = @_; 160 161 my $row = $YOUR_CONTROLLED_TABLE->create( $param ); 162 $row->dbi_commit(); 163 } 164 165Note that the new object creation code a Class::DBI style API can be 166called against the model alias of the table this controller controls. 167That won't work if you are controlling multiple tables. The same 168holds for the edit and delete methods. 169 170=back 171 172Note that all generated names are based on the name of the form method. 173The name is made with a brain dead regex which simply strips _form from 174that name. 175 176=back 177 178=head2 method KEYWORDS 179 180Most of the method keywords depend on the method's type. This one doesn't: 181 182=over 4 183 184=item extra_args 185 186Make this a comma separated list of arguments your method should expect. 187Example: 188 189 extra_args `$cust_id`, `@params`; 190 191Note that there is almost no magic here. These will simply be added 192to the method's opening comment and argument capturing code. So 193if the above example appeared in a handler method, the stub would look 194roughly like this: 195 196 #-------------------------------------------------- 197 # $self->method_name( $cust_id, @params ) 198 #-------------------------------------------------- 199 sub method_name { 200 my ( $self, $cust_id, @params ) = @_; 201 } 202 203=back 204 205=head1 SUPPORTED METHOD TYPES 206 207Note Well: Gantry's handlers must be called do_*. The leading do_ 208will not be magically supplied. Type it yourself. 209 210Each method must have a type. This backend supports the following types 211(where support may vary depending on the type): 212 213=over 4 214 215=item stub 216 217Generates an empty method body. (But it handles arguments, see 218extra_args above.) 219 220=item main_listing 221 222Generates a method, which you should probably name do_main, which produces 223a listing of all the items in a table sorted by the columns in the table's 224foreign_display. 225 226You may include the following keys in the method block: 227 228=over 4 229 230=item rows 231 232An integer number of rows to display on each page of main listing output. 233There is no default. If you omit this, you get all the rows, which is 234painful if there are very many. 235 236You must be using DBIx::Class for this to be effective. 237 238=item cols 239 240This is the list of columns that should appear in the listing. 241More than 5 or 6 will likely look funny. Use the field names from 242the table you are controlling. 243 244=item col_labels 245 246This optional list allows you to specify labels for the columns instead 247of using the label specfied in the field block of the controlled table. 248Each list element is either a simple string which becomes the label 249or a pair in which the key is the label and the value is a url (or code 250which builds one) which becomes the href of an html link. Example: 251 252 col_labels `Better Text`, 253 Label => `$self->location() . '/exotic/locaiton'`; 254 255Note that for pairs, you may use any valid Perl in the link text. Enclose 256it in backquotes. It will not be modified, mind your own quotes. 257 258=item extra_args 259 260See above. 261 262=item header_options 263 264These are the options that will appear at the end of the column label 265stripe at the top of the output table. Typically this is just: 266 267 header_options Add; 268 269But you can expand on that in a couple of ways. You can have other 270options: 271 272 header_options AddBuyer, AddSeller; 273 274These will translate into href links in the html page as 275 276 current_base_uri/addbuyer 277 current_base_uri/addseller 278 279(In Gantry this means you should have do_addbuyer and do_addseller 280methods in the same .pm file where the main_listing lives.) 281 282You can also control the generated url: 283 284 header_options AddUser => `$self->exotic_location() . "/strange_add"`; 285 286Put valid Perl inside the backquotes. It will NOT be changed in any way. 287You must ensure that the code will work in the final app. In this case 288that likely means that exotic_location should return a uri which is 289mentioned in a Location block in httpd.conf. Further, the module 290set as the handler for that location must have a method called 291do_strange_add. 292 293=item html_template 294 295The name of the Template Toolkit file to use as the view for this page. 296By default this is results.tt for main_listing methods and main.tt for 297base_link methods. 298 299=item row_options 300 301These yield href links at the end of each row in the output table. 302Typical example: 303 304 row_options Edit, Delete; 305 306These work just like header_options with one exception. The url has 307the id of the row appended at the end. 308 309If you say 310 311 row_options Edit => `$url`; 312 313You must make sure that the url is exactly correct (including appending 314'/$id' to it). Supplied values will be taken literally. 315 316=item title 317 318The browser window title for this page. 319 320=back 321 322=item AutoCRUD_form 323 324Generates a method, usually called _form, which Gantry::Plugins::AutoCRUD 325calls from its do_add and do_edit methods. 326 327You may include the following keys in the method block: 328 329=over 4 330 331=item all_fields_but 332 333A comma separated list of fields that should not appear on the form. 334Typical example: 335 336 all_fields_but id; 337 338=item extra_args 339 340See above. Note that for the extra_args to be available, they must 341be passed from the AutoCRUD calling method. 342 343=item extra_keys 344 345List key/value pairs you want to appear in the hash returned by the method. 346Example: 347 348 extra_keys 349 legend => `$self->path_info =~ /edit/i ? 'Edit' : 'Add'`, 350 javascript => `$self->calendar_month_js( 'customer' )`; 351 352The javascript entry is exactly correct for a form named customer 353using Gantry::Plugins::Calendar. 354 355Note that whatever you put inside the backquotes appears EXACTLY as is 356in the generated output. Nothing will be done to it, not even quote 357escaping. 358 359=item fields 360 361A comma separated list of the fields to include on the form. The 362names must match fields of table you are controlling. 363Example: 364 365 fields first_name, last_name, street, city, state, zip; 366 367Note that all_fields_but is usually easier, but directly using fields 368allows you to change the order in which the entry widgets appear. 369 370=item form_name 371 372The name of the html form. This is important if you are using javascript 373which needs to refer to the form (for example if you are using 374Gantry::Plugins::Calendar). 375 376=back 377 378=item CRUD_form 379 380Takes the same keywords as AutoCRUD_form but makes a form method suitable 381for use with Gantry::Plugins::CRUD. Note that due to the callback scheme 382used in that module, the name you give the generated method is entirely up 383to you. Note that the method is generated in the stub and therefore must 384be included during initial building to avoid gymnastics (like renaming the 385stub, genning, renaming the regened stub, moving the form method from that 386file back into the real stub...). 387 388=back 389 390=head1 METHODS 391 392To keep podcoverage tests happy. 393 394=over 4 395 396=item backend_block_keywords 397 398Tells tentmaker that I understand these config section backend block keywords: 399 400 no_gen 401 dbix 402 full_use 403 template 404 405=item what_do_you_make 406 407Tells tentmaker what this module makes. Summary: Gantry controller modules. 408 409=item gen_Control 410 411Called by Bigtop::Parser to get me to do my thing. 412 413=item build_config_lists 414 415What I call on the various AST packages to do my thing. 416 417=item build_init_sub 418 419What I call on the various AST packages to do my thing. 420 421=item setup_template 422 423Called by Bigtop::Parser so the user can substitute an alternate template 424for the hard coded one here. 425 426=back 427 428=head1 AUTHOR 429 430Phil Crow <crow.phil@gmail.com> 431 432=head1 COPYRIGHT and LICENSE 433 434Copyright (C) 2005 by Phil Crow 435 436This library is free software; you can redistribute it and/or modify 437it under the same terms as Perl itself, either Perl version 5.8.6 or, 438at your option, any later version of Perl 5 you may have available. 439 440=head1 IGNORE the REST 441 442After this paragraph, you will likely see other POD. It belongs to 443the generated modules. I just couldn't figure out how to hide it. 444 445=cut 446 447use Bigtop::Backend::Control; 448use File::Spec; 449use Inline; 450use Bigtop; 451 452#----------------------------------------------------------------- 453# Register keywords in the grammar 454#----------------------------------------------------------------- 455 456BEGIN { 457 Bigtop::Parser->add_valid_keywords( 458 Bigtop::Keywords->get_docs_for( 459 'controller', 460 qw( 461 plugins 462 autocrud_helper 463 ) 464 ) 465 ); 466 467 Bigtop::Parser->add_valid_keywords( 468 Bigtop::Keywords->get_docs_for( 469 'method', 470 qw( 471 extra_args 472 order_by 473 rows 474 paged_conf 475 cols 476 col_labels 477 pseudo_cols 478 header_options 479 header_option_perms 480 authed_methods 481 permissions 482 literal 483 livesearch 484 row_options 485 row_option_perms 486 title 487 html_template 488 limit_by 489 where_terms 490 all_fields_but 491 fields 492 extra_keys 493 form_name 494 expects 495 returns 496 ) 497 ) 498 ); 499 500 Bigtop::Parser->add_valid_keywords( 501 Bigtop::Keywords->get_docs_for( 502 'field', 503 qw( 504 label 505 searchable 506 pseudo_value 507 unique_name 508 html_form_type 509 html_form_optional 510 html_form_constraint 511 html_form_default_value 512 html_form_cols 513 html_form_rows 514 html_form_display_size 515 html_form_hint 516 html_form_class 517 html_form_options 518 html_form_foreign 519 html_form_onchange 520 html_form_fieldset 521 date_select_text 522 html_form_raw_html 523 ) 524 ) 525 ); 526} 527 528#----------------------------------------------------------------- 529# The Default Template 530#----------------------------------------------------------------- 531 532our $template_is_setup = 0; 533our $default_template_text = <<'EO_TT_blocks'; 534[% BLOCK hashref %] 535 return { 536[% IF authed_methods.keys.0 %] 537 authed_methods => [ 538[% FOREACH k IN authed_methods.keys %] 539 { action => '[% k %]', group => '[% authed_methods.$k %]' }, 540[% END %] 541 ], 542[% END %] 543[% IF permissions.size >= 1 %] 544 permissions => { 545 bits => '[% permissions.0 %]', 546 group => '[% permissions.1 %]' 547 }, 548[% END %] 549[% IF literals.0 %] 550 551[% FOREACH literal IN literals %] 552 [% literal %], 553[% END %] 554[% END %] 555 }; 556[% END %] 557 558[% BLOCK base_module %] 559package [% app_name %]; 560 561use strict; 562use warnings; 563 564our $VERSION = '0.01'; 565 566use base '[% gen_package_name %]'; 567 568[% FOREACH module IN external_modules %] 569use [% module %]; 570[% END %] 571[% child_output %] 572 573 574[%- IF class_accessors -%] 575[% class_accessors %] 576[%- END -%] 577 578[% IF init_sub %] 579#----------------------------------------------------------------- 580# $self->init( $r ) 581#----------------------------------------------------------------- 582# This method inherited from [% gen_package_name +%] 583[% END %] 584[% IF config_accessor_comments %] 585[% config_accessor_comments %] 586[% END %] 587 5881; 589 590[% pod %] 591[% END %] 592 593[% BLOCK gen_base_module %] 594# NEVER EDIT this file. It was generated and will be overwritten without 595# notice upon regeneration of this application. You have been warned. 596package [% gen_package_name %]; 597 598use strict; 599use warnings; 600 601[% IF full_use_statement %] 602use Gantry qw{[% IF engine +%] 603 -Engine=[% engine %][% END %][% IF template_engine +%] 604 -TemplateEngine=[% template_engine %][% END +%] 605[% IF plugins %] -PluginNamespace=[% app_name +%] 606 [% plugins +%] 607[% END %] 608}; 609[% ELSE %] 610use Gantry[% IF template_engine %] qw{ -TemplateEngine=[% template_engine %] }[% END %]; 611[% END %] 612 613use JSON; 614use Gantry::Utils::TablePerms; 615 616our @ISA = qw( Gantry ); 617 618[% FOREACH module IN external_modules %] 619use [% module %]; 620[% END %] 621 622[% IF dbix %] 623use [% base_model %]; 624sub schema_base_class { return '[% base_model %]'; } 625use Gantry::Plugins::DBIxClassConn qw( get_schema ); 626[% END %] 627 628#----------------------------------------------------------------- 629# $self->namespace() or [% app_name %]->namespace() 630#----------------------------------------------------------------- 631sub namespace { 632 return '[% app_name %]'; 633} 634 635[% init_sub %] 636 637[% config_accessors %] 638[% IF child_output %] 639[% child_output %] 640[% ELSE %] 641#----------------------------------------------------------------- 642# $self->do_main( ) 643#----------------------------------------------------------------- 644sub do_main { 645 my ( $self ) = @_; 646 647 $self->stash->view->template( 'main.tt' ); 648 $self->stash->view->title( '[% dist_name %]' ); 649 650 $self->stash->view->data( { pages => $self->site_links() } ); 651} # END do_main 652 653#----------------------------------------------------------------- 654# $self->site_links( ) 655#----------------------------------------------------------------- 656sub site_links { 657 my $self = shift; 658 659 return [ 660[% FOREACH page IN pages %] 661[% IF page.link.match( '^/' ) %] 662 { link => '[% page.link %]', label => '[% page.label %]' }, 663[% ELSE %] 664 { link => $self->app_rootp() . '/[% page.link %]', label => '[% page.label %]' }, 665[% END %] 666[% END %] 667 ]; 668} # END site_links 669[% END %] 670 6711; 672 673[% gen_pod +%] 674[% END %] 675 676[% BLOCK test_file %] 677use strict; 678use warnings; 679 680use Test::More tests => [% module_count %]; 681 682[% FOREACH module IN modules %] 683use_ok( '[% module %]' ); 684[% END %] 685[% END %] 686 687[% BLOCK pod_test %] 688use Test::More; 689 690eval "use Test::Pod 1.14"; 691plan skip_all => 'Test::Pod 1.14 required' if $@; 692plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; 693 694all_pod_files_ok(); 695[% END %] 696 697[% BLOCK pod_cover_test %] 698use Test::More; 699 700eval "use Test::Pod::Coverage 1.04"; 701plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@; 702plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; 703 704all_pod_coverage_ok(); 705[% END %] 706 707[% BLOCK run_test %] 708use strict; 709use warnings; 710 711use Test::More tests => [% num_tests %]; 712 713use [% app_name %] qw{ 714 -Engine=CGI 715 -TemplateEngine=[% template_engine || TT +%] 716[% IF plugins %] -PluginNamespace=[% app_name +%] 717 [% plugins +%] 718[% END %] 719}; 720 721use Gantry::Server; 722use Gantry::Engine::CGI; 723 724# these tests must contain valid template paths to the core gantry templates 725# and any application specific templates 726 727my $cgi = Gantry::Engine::CGI->new( { 728 config => { 729[% FOREACH var_pair IN configs %] 730 [% var_pair.0 %] => '[% var_pair.1 %]', 731[% END %] 732 }, 733 locations => { 734[% FOREACH location IN locations %] 735 '[% location.0 %]' => '[% location.1 %]', 736[% END %] 737 }, 738} ); 739 740my @tests = qw( 741[% FOREACH location IN locations %] 742 [% location.0 +%] 743[% END %] 744); 745 746my $server = Gantry::Server->new(); 747$server->set_engine_object( $cgi ); 748 749SKIP: { 750 751 eval { 752 require DBD::SQLite; 753 }; 754 skip 'DBD::SQLite is required for run tests.', [% num_tests %] if ( $@ ); 755 756 unless ( -f 'app.db' ) { 757 skip 'app.db sqlite database required for run tests.', [% num_tests %]; 758 } 759 760 foreach my $location ( @tests ) { 761 my( $status, $page ) = $server->handle_request_test( $location ); 762 ok( $status eq '200', 763 "expected 200, received $status for $location" ); 764 765 if ( $status ne '200' ) { 766 print STDERR $page . "\n\n"; 767 } 768 } 769 770} 771[% END %] 772 773[% BLOCK controller_block %] 774package [% package_name %]; 775 776use strict; 777use warnings; 778 779[% IF sub_modules %] 780our $VERSION = '0.01'; 781 782[% END %] 783use base '[% inherit_from %]'; 784[% FOREACH module IN sub_modules %] 785[% IF loop.first %] 786 787[% END %] 788use [% module %]; 789[% END %] 790[% child_output %] 791 792[% class_accessors %] 793 7941; 795 796[% pod %] 797[% END %] 798 799[% BLOCK pod %] 800=head1 NAME 801 802[% IF sub_module %] 803[% package_name %] - A controller in the [% app_name %] application 804[% ELSE %] 805[% package_name %] - the base module of this web app 806[% END %] 807 808=head1 SYNOPSIS 809 810This package is meant to be used in a stand alone server/CGI script or the 811Perl block of an httpd.conf file. 812 813Stand Alone Server or CGI script: 814 815 use [% package_name %]; 816 817 my $cgi = Gantry::Engine::CGI->new( { 818 config => { 819 #... 820 }, 821 locations => { 822[% IF sub_module %] 823 '/someurl' => '[% package_name %]', 824[% ELSE %] 825 '/' => '[% package_name %]', 826[% END %] 827 #... 828 }, 829 } ); 830 831httpd.conf: 832 833 <Perl> 834 # ... 835 use [% package_name %]; 836 </Perl> 837[% IF sub_module %] 838 839 <Location /someurl> 840 SetHandler perl-script 841 PerlHandler [% package_name +%] 842 </Location> 843[% END %] 844 845If all went well, one of these was correctly written during app generation. 846 847=head1 DESCRIPTION 848 849This module was originally generated by Bigtop. But feel free to edit it. 850You might even want to describe the table this module controls here. 851 852[% IF sub_module %] 853=head1 METHODS 854[% ELSIF gen_package_name AND NOT sub_modules %] 855=head1 METHODS (inherited from [% gen_package_name %]) 856[% ELSE %] 857=head1 METHODS 858[% END %] 859 860=over 4 861 862[% FOREACH method IN methods %] 863=item [% method %] 864 865 866[% END %] 867 868=back 869 870[% IF gen_package_name AND mixins %] 871 872=head1 METHODS INHERITED FROM [% gen_package_name +%] 873 874=over 4 875 876[% FOREACH mixin IN mixins %] 877=item [% mixin %] 878 879 880[% END %] 881 882=back 883 884[% END -%] 885 886=head1 [% other_module_text +%] 887 888[% FOREACH used_module IN used_modules %] 889 [% used_module +%] 890[% END %] 891[% FOREACH see_also IN sub_modules %] 892 [% see_also +%] 893[% END %] 894 895=head1 AUTHOR 896 897[% FOREACH author IN authors %] 898[% author.0 %][% IF author.1 %], E<lt>[% author.1 %]E<gt>[% END +%] 899 900[% END %] 901[%- IF contact_us %] 902=head1 CONTACT US 903 904[% contact_us +%] 905 906[% END -%] 907=head1 COPYRIGHT AND LICENSE 908 909Copyright (C) [% year %] [% copyright_holder %] 910 911 912[% IF license_text %] 913[% license_text %] 914 915[% ELSE %] 916This library is free software; you can redistribute it and/or modify 917it under the same terms as Perl itself, either Perl version 5.8.6 or, 918at your option, any later version of Perl 5 you may have available. 919[% END %] 920 921=cut 922[% END %] 923 924[% BLOCK gen_pod %] 925=head1 NAME 926 927[% gen_package_name %] - generated support module for [% package_name +%] 928 929=head1 SYNOPSIS 930 931In [% package_name %]: 932 933 use base '[% gen_package_name %]'; 934 935=head1 DESCRIPTION 936 937This module was generated by Bigtop (and IS subject to regeneration) to 938provide methods in support of the whole [% package_name +%] 939application. 940 941[% package_name %] should inherit from this module. 942 943=head1 METHODS 944 945=over 4 946 947[% FOREACH method IN methods %] 948=item [% method +%] 949 950[% END %] 951 952=back 953 954=head1 AUTHOR 955 956[% FOREACH author IN authors %] 957[% author.0 %][% IF author.1 %], E<lt>[% author.1 %]E<gt>[% END +%] 958 959[% END %] 960[%- IF contact_us %] 961=head1 CONTACT US 962 963[% contact_us +%] 964 965[% END -%] 966=head1 COPYRIGHT AND LICENSE 967 968Copyright (C) [% year %] [% copyright_holder %] 969 970 971[% IF license_text %] 972[% license_text %] 973 974[% ELSE %] 975This library is free software; you can redistribute it and/or modify 976it under the same terms as Perl itself, either Perl version 5.8.6 or, 977at your option, any later version of Perl 5 you may have available. 978[% END %] 979 980=cut 981[% END %] 982 983[% BLOCK gen_controller_pod %] 984=head1 NAME 985 986[% gen_package_name %] - generated support module for [% package_name +%] 987 988=head1 SYNOPSIS 989 990In [% package_name %]: 991 992 use base '[% gen_package_name %]'; 993 994=head1 DESCRIPTION 995 996This module was generated by bigtop and IS subject to regeneration. 997Use it in [% package_name %] to provide the methods below. 998Feel free to override them. 999 1000=head1 METHODS 1001 1002=over 4 1003 1004[% FOREACH method IN gen_methods %] 1005=item [% method +%] 1006 1007[% END %] 1008 1009=back 1010 1011=head1 AUTHOR 1012 1013Generated by bigtop and subject to regeneration. 1014 1015=cut 1016[% END %] 1017 1018[% BLOCK gen_controller_block %] 1019# NEVER EDIT this file. It was generated and will be overwritten without 1020# notice upon regeneration of this application. You have been warned. 1021package [% gen_package_name %]; 1022 1023use strict; 1024use warnings; 1025 1026[% IF wsdl %] 1027use [% app_name %] qw( 1028 -PluginNamespace=[% package_name +%] 1029 SOAP::[% soap_style +%] 1030); 1031 1032our @ISA = qw( [% app_name %] ); 1033[% ELSIF plugins %] 1034use [% app_name %] qw{ 1035 -PluginNamespace=[% package_name +%] 1036 [% plugins +%] 1037}; 1038 1039our @ISA = qw( [% app_name %] ); 1040 1041use JSON; 1042use Gantry::Utils::TablePerms; 1043[% ELSE %] 1044use base '[% app_name %]'; 1045use JSON; 1046use Gantry::Utils::TablePerms; 1047[% END %] 1048 1049[% child_output %] 1050[% IF wsdl %][% wsdl %][% END %] 1051[% IF init_sub %] 1052 1053[% init_sub %] 1054[% END %] 1055[% IF config_accessors %] 1056[% config_accessors %] 1057[% END %] 1058[% IF plugins %] 1059 1060#----------------------------------------------------------------- 1061# $self->namespace() or Apps::Checkbook->namespace() 1062#----------------------------------------------------------------- 1063sub namespace { 1064 return '[% package_name %]'; 1065} 1066[% END %] 1067 10681; 1069 1070[% gen_pod %] 1071 1072[% END %] 1073 1074[% BLOCK use_stub %] 1075use [% module -%] 1076[%- IF imports -%] qw( 1077 [% imports.join("\n ") %] 1078 1079); 1080 1081[%- ELSE -%]; 1082[% END %] 1083[% END %] 1084 1085[% BLOCK explicit_use_stub %] 1086use [% module %][% IF import_list %] [% import_list %][% END %]; 1087[% END %] 1088 1089[% BLOCK export_array %] 1090our @EXPORT = qw( 1091[% FOREACH exported_sub IN exported_subs %] 1092 [% exported_sub +%] 1093[% END %] 1094); 1095[% END %] 1096 1097[% BLOCK dbix_uses %] 1098[% use_my_model %] 1099use [% base_model %]; 1100sub schema_base_class { return '[% base_model %]'; } 1101use Gantry::Plugins::DBIxClassConn qw( get_schema ); 1102[% END %] 1103 1104[% BLOCK get_orm_helper %] 1105#----------------------------------------------------------------- 1106# get_orm_helper( ) 1107#----------------------------------------------------------------- 1108sub get_orm_helper { 1109 return '[% helper %]'; 1110} 1111 1112[% END %] 1113 1114[% BLOCK class_access %] 1115#----------------------------------------------------------------- 1116# get_model_name( ) 1117#----------------------------------------------------------------- 1118sub get_model_name { 1119 return $[% model_alias %]; 1120} 1121 1122[% END %] 1123 1124[% BLOCK text_description %] 1125#----------------------------------------------------------------- 1126# text_descr( ) 1127#----------------------------------------------------------------- 1128sub text_descr { 1129 return '[% description %]'; 1130} 1131[% END %] 1132 1133[% BLOCK controller_method +%] 1134#----------------------------------------------------------------- 1135# $self->[% method_name %]( [% child_output.doc_args.join( ', ' ) %] ) 1136#----------------------------------------------------------------- 1137# This method inherited from [% gen_package_name %] 1138 1139[% END %] 1140 1141[% BLOCK gen_controller_method +%] 1142#----------------------------------------------------------------- 1143# $self->[% method_name %]( [% child_output.doc_args.join( ', ' ) %] ) 1144#----------------------------------------------------------------- 1145sub [% method_name %] { 1146[% child_output.body %] 1147} # END [% method_name %] 1148 1149[% END %] 1150 1151[% BLOCK init_method_body %] 1152[% arg_capture %] 1153 1154 # process SUPER's init code 1155 $self->SUPER::init( $r ); 1156 1157[% FOREACH config IN configs %] 1158 $self->set_[% config %]( $self->fish_config( '[% config %]' ) || '' ); 1159[% END %] 1160[% END %] 1161 1162[% BLOCK config_accessors %] 1163[% FOREACH config IN configs %] 1164#----------------------------------------------------------------- 1165# $self->set_[% config %]( $new_value ) 1166#----------------------------------------------------------------- 1167sub set_[% config %] { 1168 my ( $self, $value ) = @_; 1169 1170 $self->{ __[% config %]__ } = $value; 1171} 1172 1173#----------------------------------------------------------------- 1174# $self->[% config %]( ) 1175#----------------------------------------------------------------- 1176sub [% config %] { 1177 my $self = shift; 1178 1179 return $self->{ __[% config %]__ }; 1180} 1181 1182[% END %] 1183[% END %] 1184 1185[% BLOCK arg_capture %] 1186[% FOREACH arg IN args %] 1187 my [% arg %] = shift; 1188[% END %] 1189[% END %] 1190 1191[% BLOCK arg_capture_st_nick_style %] 1192 my ( [% args.join( ', ' ) %] ) = @_; 1193[% END %] 1194 1195[% BLOCK self_setup %] 1196 $self->stash->view->template( '[% template %]' ); 1197 $self->stash->view->title( '[% title %]' ); 1198[% IF with_real_loc %] 1199 1200 my $real_location = $self->location() || ''; 1201 if ( $real_location ) { 1202 $real_location =~ s{/+$}{}; 1203 $real_location .= '/'; 1204 } 1205[% END %] 1206[% END %] 1207 1208[% BLOCK main_links %] 1209 $self->stash->view->data( { pages => $self->site_links() } ); 1210[% END %] 1211 1212[% BLOCK site_links %] 1213 return [ 1214[% FOREACH page IN pages %] 1215 { link => [% page.link %], label => '[% page.label %]' }, 1216[% END %] 1217 ]; 1218[% END %] 1219 1220[% BLOCK main_heading %] 1221[% IF limit_by %] 1222 my $header_option_suffix = ( $[% limit_by %] ) ? "/$[% limit_by %]" : ''; 1223 1224[% END %] 1225 my @header_options = ( 1226[% FOREACH option IN header_options %] 1227 { 1228 text => '[% option.text %]', 1229 link => [% option.location +%], 1230 type => '[% option.type %]', 1231 }, 1232[% END %] 1233 ); 1234 1235 my $retval = { 1236 headings => [ 1237[% FOREACH heading IN headings %] 1238[% IF heading.simple %] 1239 [% IF heading.simple.match( "'" ) %]q[[% heading.simple %]][% ELSE %]'[% heading.simple %]'[% END %], 1240[% ELSIF heading.href %] 1241 '<a href=' . [% heading.href.link %] . [% IF heading.href.text.match( "'" ) %]q[>[% heading.href.text %]</a>][% ELSE %]'>[% heading.href.text %]</a>'[% END %], 1242[% END %] 1243[% END %] 1244 ], 1245 }; 1246[% END %] 1247 1248[% BLOCK main_table %] 1249 1250 [%- IF livesearch %] 1251 $retval->{ livesearch } = 1; 1252 1253 [% END -%] 1254 my $params = $self->params; 1255 1256[% IF where_terms.size > 0 %] 1257 my $search = { 1258[% FOREACH where_term IN where_terms %] 1259 [% where_term.col_name %] => [% where_term.value %], 1260[% END %] 1261 }; 1262[% ELSE %] 1263 my $search = {}; 1264[% END %] 1265 if ( $params->{ search } ) { 1266 my $form = $self->form(); 1267 1268 my @searches; 1269 foreach my $field ( @{ $form->{ fields } } ) { 1270 if ( $field->{ searchable } ) { 1271 push( @searches, 1272 ( $field->{ name } => { 'like', "%$params->{ search }%" } ) 1273 ); 1274 } 1275 } 1276 1277 $search = { 1278 -or => \@searches 1279 } if scalar( @searches ) > 0; 1280 } 1281 1282 my @row_options = ( 1283[% FOREACH row_option IN row_options %] 1284 { 1285 text => '[% row_option.text %]', 1286[% IF row_option.location %] 1287 link => [% row_option.location %], 1288[% END %] 1289 type => '[% row_option.type %]', 1290 }, 1291[% END %] 1292 ); 1293 1294 my $perm_obj = Gantry::Utils::TablePerms->new( 1295 { 1296 site => $self, 1297 real_location => $real_location, 1298 header_options => \@header_options, 1299 row_options => \@row_options, 1300 } 1301 ); 1302 1303 $retval->{ header_options } = $perm_obj->real_header_options; 1304 1305 my $limit_to_user_id = $perm_obj->limit_to_user_id; 1306 $search->{ user_id } = $limit_to_user_id if ( $limit_to_user_id ); 1307 1308[% IF dbix AND rows AND limit_by -%] 1309 my $page = $params->{ page } || 1; 1310 1311 if ( $[% limit_by %] ) { 1312 $search->{ [% limit_by %] } = $[% limit_by %]; 1313 } 1314 1315 my $schema = $self->get_schema(); 1316 my $results = $[% model %]->get_listing( 1317 { 1318[% IF pseudo_cols.size > 0 %] 1319 '+select' => [[% FOREACH pseudo_col IN pseudo_cols %][% pseudo_col.field %][% UNLESS loop.last %] [% END %][% END %]], 1320 '+as' => [[% FOREACH pseudo_col IN pseudo_cols %]'[% pseudo_col.alias %]'[% UNLESS loop.last %] [% END %][% END %]], 1321[% END %] 1322 schema => $schema, 1323 rows => [% rows %], 1324 where => $search,[% IF order_by %][% "\n" %] order_by => '[% order_by %]',[% END +%] 1325 } 1326 ); 1327 1328 my $rows = $results->page( $page ); 1329 $retval->{ page } = $rows->pager(); 1330 1331 ROW: 1332 while ( my $row = $rows->next ) { 1333[%- ELSIF dbix AND rows -%] 1334 my $page = $params->{ page } || 1; 1335 1336 my $schema = $self->get_schema(); 1337 my $results = $[% model %]->get_listing( 1338 { 1339[% IF pseudo_cols.size > 0 %] 1340 '+select' => [[% FOREACH pseudo_col IN pseudo_cols %][% pseudo_col.field %][% UNLESS loop.last %] [% END %][% END %]], 1341 '+as' => [[% FOREACH pseudo_col IN pseudo_cols %]'[% pseudo_col.alias %]'[% UNLESS loop.last %] [% END %][% END %]], 1342[% END %] 1343 schema => $schema, 1344 rows => [% rows %], 1345 where => $search,[% IF order_by %][% "\n" %] order_by => '[% order_by %]',[% END +%] 1346 } 1347 ); 1348 1349 my $rows = $results->page( $page ); 1350 $retval->{ page } = $rows->pager(); 1351 1352 ROW: 1353 while ( my $row = $rows->next ) { 1354[%- ELSIF dbix AND limit_by -%] 1355 if ( $[% limit_by %] ) { 1356 $search->{ [% limit_by %] } = $[% limit_by %]; 1357 } 1358 1359 my $schema = $self->get_schema(); 1360 my @rows = $[% model %]->get_listing( 1361 { 1362[% IF pseudo_cols.size > 0 %] 1363 '+select' => [[% FOREACH pseudo_col IN pseudo_cols %][% pseudo_col.field %][% UNLESS loop.last %] [% END %][% END %]], 1364 '+as' => [[% FOREACH pseudo_col IN pseudo_cols %]'[% pseudo_col.alias %]'[% UNLESS loop.last %] [% END %][% END %]], 1365[% END %] 1366 schema => $schema, 1367 where => $search,[% IF order_by %][% "\n" %] order_by => '[% order_by %]',[% END +%] 1368 } 1369 ); 1370 1371 ROW: 1372 foreach my $row ( @rows ) { 1373[%- ELSIF dbix -%] 1374 my $schema = $self->get_schema(); 1375 my @rows = $[% model %]->get_listing( 1376 { 1377[% IF pseudo_cols.size > 0 %] 1378 '+select' => [[% FOREACH pseudo_col IN pseudo_cols %][% pseudo_col.field %][% UNLESS loop.last %] [% END %][% END %]], 1379 '+as' => [[% FOREACH pseudo_col IN pseudo_cols %]'[% pseudo_col.alias %]'[% UNLESS loop.last %] [% END %][% END %]], 1380[% END %] 1381 schema => $schema, 1382 where => $search,[% IF order_by %][% "\n" %] order_by => '[% order_by %]',[% END +%] 1383 } 1384 ); 1385 1386 ROW: 1387 foreach my $row ( @rows ) { 1388[%- ELSE -%] 1389 my @rows = $[% model %]->get_listing([% IF order_by %] { order_by => '[% order_by %]', } [% END %]); 1390 1391 ROW: 1392 foreach my $row ( @rows ) { 1393[%- END -%] 1394 1395 last ROW if $perm_obj->hide_all_data; 1396 1397 my $id = $row->id; 1398[% FOREACH foreigner IN foreigners %] 1399 my $[% foreigner %] = ( $row->[% foreigner %] ) 1400 ? $row->[% foreigner %]->foreign_display() 1401 : ''; 1402[% END %] 1403 1404 push( 1405 @{ $retval->{rows} }, { 1406 orm_row => $row, 1407 data => [ 1408[% FOREACH data_col IN data_cols %] 1409 [% data_col %], 1410[% END %] 1411 ], 1412 options => $perm_obj->real_row_options( $row ), 1413 } 1414 ); 1415 } 1416 1417 if ( $params->{ json } ) { 1418 $self->template_disable( 1 ); 1419 1420 my $obj = { 1421 headings => $retval->{ headings }, 1422 header_options => $retval->{ header_options }, 1423 rows => $retval->{ rows }, 1424 }; 1425 1426 my $json = to_json( $obj, { allow_blessed => 1 } ); 1427 return( $json ); 1428 } 1429 1430 $self->stash->view->data( $retval ); 1431[% END %] 1432 1433[% BLOCK form_body %] 1434[% arg_capture %] 1435[%- IF dbix -%] 1436 my $selections = $[% model %]->get_form_selections( 1437 { 1438 schema => $self->get_schema(), 1439[% IF refers_to.size > 0 %] 1440 foreign_tables => { 1441[% FOREACH rt_table IN refers_to %] 1442 '[% rt_table %]' => 1, 1443[% END %] 1444 } 1445[% END -%] 1446 } 1447 ); 1448 1449[%- ELSE -%] 1450 my $selections = $[% model %]->get_form_selections(); 1451 1452[%- END -%] 1453 1454 return { 1455[% IF form_name %] name => '[% form_name %]', 1456[% END -%] 1457[% IF raw_row %] row => $row, 1458[% ELSE %] row => $data->{row}, 1459[% END -%] 1460[% FOREACH extra_key_name IN extra_keys.keys() %] 1461 [% extra_key_name %] => [% extra_keys.$extra_key_name %], 1462[% END %] 1463 fields => [ 1464[% FOREACH field IN fields %] 1465 { 1466[% FOREACH key = field.keys %] 1467[% IF key == 'options_string' %] 1468 options => [% field.$key %], 1469[% ELSIF key == 'constraint' OR field.$key.match( '^\d+$' ) %] 1470 [% key %] => [% field.$key %], 1471[% ELSIF key == 'options' %] 1472 options => [ 1473[% arg_list = field.$key %] 1474[% FOREACH pair IN arg_list %] 1475[% FOREACH pair_key IN pair.keys() %] 1476 { label => '[% pair_key %]', value => '[% pair.$pair_key %]' }, 1477[% END %] 1478[% END %] 1479 ], 1480[% ELSE %] 1481 [% key %] => [% IF field.$key.match( "'" ) %]q[[% field.$key %]][% ELSE %]'[% field.$key %]'[% END %], 1482[% END %] 1483[% END %] 1484 }, 1485[% END %] 1486 ], 1487 }; 1488[% END %] 1489 1490[% BLOCK crud_helpers %] 1491 1492my $[% crud_name %] = Gantry::Plugins::CRUD->new( 1493 add_action => \&[% crud_name %]_add, 1494 edit_action => \&[% crud_name %]_edit, 1495 delete_action => \&[% crud_name %]_delete, 1496 form => __PACKAGE__->can( '[% form_method_name %]' ), 1497 redirect => \&[% crud_name %]_redirect, 1498 text_descr => '[% text_descr %]', 1499); 1500 1501#----------------------------------------------------------------- 1502# $self->[% crud_name %]_redirect( $data ) 1503# The generated version mimics the default behavior, feel free 1504# to delete the redirect key from the constructor call for $crud 1505# and this sub. 1506#----------------------------------------------------------------- 1507sub [% crud_name %]_redirect { 1508 my ( $self, $data ) = @_; 1509 return $self->location; 1510} 1511 1512#------------------------------------------------- 1513# $self->do_add( ) 1514#------------------------------------------------- 1515sub do_add { 1516 my $self = shift; 1517[% IF with_perms %] 1518 1519 Gantry::Plugins::CRUD::verify_permission( { site => $self } ); 1520[% END %] 1521 1522 $[% crud_name %]->add( $self, { data => \@_ } ); 1523} 1524 1525#------------------------------------------------- 1526# $self->[% crud_name %]_add( $params, $data ) 1527#------------------------------------------------- 1528sub [% crud_name %]_add { 1529 my ( $self, $params, $data ) = @_; 1530 1531 # make a new row in the $[% model_alias %] table using data from $params 1532 # remember to add commit if needed 1533 1534 $[% model_alias %]->gupdate_or_create( $self, $params ); 1535} 1536 1537#------------------------------------------------- 1538# $self->do_delete( $doomed_id, $confirm ) 1539#------------------------------------------------- 1540sub do_delete { 1541 my ( $self, $doomed_id, $confirm ) = @_; 1542 1543 my $row = $[% model_alias %]->gfind( $self, $doomed_id ); 1544[% IF with_perms %] 1545 1546 Gantry::Plugins::CRUD::verify_permission( { site => $self, row => $row } ); 1547[% END %] 1548 1549 $[% crud_name %]->delete( $self, $confirm, { row => $row } ); 1550} 1551 1552#------------------------------------------------- 1553# $self->[% crud_name %]_delete( $data ) 1554#------------------------------------------------- 1555sub [% crud_name %]_delete { 1556 my ( $self, $data ) = @_; 1557 1558 # fish the id (or the actual row) from the data hash 1559 # delete it 1560 # remember to add commit if needed 1561 1562 $data->{ row }->delete; 1563} 1564 1565#------------------------------------------------- 1566# $self->do_edit( $id ) 1567#------------------------------------------------- 1568sub do_edit { 1569 my ( $self, $id ) = @_; 1570 1571 my $row = $[% model_alias %]->gfind( $self, $id ); 1572[% IF with_perms %] 1573 1574 Gantry::Plugins::CRUD::verify_permission( { site => $self, row => $row } ); 1575[% END %] 1576 1577 $[% crud_name %]->edit( $self, { row => $row } ); 1578} 1579 1580#------------------------------------------------- 1581# $self->[% crud_name %]_edit( $param, $data ) 1582#------------------------------------------------- 1583sub [% crud_name %]_edit { 1584 my( $self, $params, $data ) = @_; 1585 1586 # retrieve the row from the data hash 1587 # update the row 1588 # remember to add commit if needed 1589 1590 $data->{row}->update( $params ); 1591} 1592[% END %] 1593 1594[% BLOCK SOAP_gen_method_body %] 1595 my $self = shift; 1596 my $input = $self->soap_in; 1597 my $output_data = $self->[% internal_method %]( $input ); 1598 1599 $self->template_disable( 1 ); 1600 1601 return $self->soap_out( $output_data ); 1602[% END %] 1603 1604[% BLOCK SOAP_stub_method %] 1605#----------------------------------------------------------------- 1606# $self->[% internal_method %]( ) 1607#----------------------------------------------------------------- 1608sub [% internal_method %] { 1609 my ( $self, $input ) = @_; 1610} # END [% internal_method %] 1611[% END %] 1612 1613[% BLOCK soap_methods %] 1614 1615#----------------------------------------------------------------- 1616# $self->namespace( ) 1617#----------------------------------------------------------------- 1618sub namespace { 1619 return '[% stub_module %]'; 1620} # END namespace 1621 1622#----------------------------------------------------------------- 1623# $self->get_soap_ops 1624#----------------------------------------------------------------- 1625sub get_soap_ops { 1626 my $self = shift; 1627 1628 return { 1629 soap_name => '[% soap_name %]', 1630 location => $self->location, 1631 namespace_base => '[% namespace_base %]', 1632 operations => [ 1633[% FOREACH op IN operations %] 1634 { 1635 name => '[% op.name %]', 1636 expects => [ 1637[% FOREACH param IN op.expects %] 1638 { name => '[% param.name %]', type => '[% param.type %]' }, 1639[% END %] 1640 ], 1641 returns => [ 1642[% FOREACH param IN op.returns %] 1643 { name => '[% param.name %]', type => '[% param.type %]' }, 1644[% END %] 1645 ], 1646 }, 1647[% END %] 1648 ], 1649 }; 1650} # END get_soap_ops 1651[% END %] 1652[% BLOCK soap_doc_advice %] 1653#----------------------------------------------------------------- 1654# $self->[% handler_method %]( ) 1655#----------------------------------------------------------------- 1656sub [% handler_method %] { 1657[% arg_capture %] 1658 1659 my $params = $self->params(); # easy way 1660 1661[% FOREACH expected_param IN soap_params.expects %] 1662 my $[% expected_param.name %] = $params->{ [% expected_param.name %] }; 1663[% END %] 1664 1665# hard way: 1666# my $xmlobj = XML::LibXML->new(); 1667# my $dom = $xmlobj->parse_string( $self->get_post_body() ) 1668# or return return_error( "Mal-formed XML request: $!" ); 1669# 1670[% FOREACH expected_param IN soap_params.expects %] 1671# my ( $[% expected_param.name %]_node ) = $dom->getElementsByLocalName( '[% expected_param.name %]' ); 1672# my $[% expected_param.name %] = $[% expected_param.name %]_node->textContent; 1673[% END %] 1674 1675[% FOREACH returned_param IN soap_params.returns %] 1676 my $[% returned_param.name %]; 1677[% END %] 1678 1679 my $time = $self->soap_current_time(); 1680 1681 my $ret_struct = [ 1682 { 1683 GantrySoapServiceResponse => [ 1684[% FOREACH returned_param IN soap_params.returns %] 1685 { [% returned_param.name %] => $[% returned_param.name %] }, 1686[% END %] 1687 ] 1688 } 1689 ]; 1690 1691 $self->soap_namespace_set( 1692 'http://usegantry.org/soapservice' 1693 ); 1694 1695 return $self->soap_out( $ret_struct, 'internal', 'pretty' ); 1696} # END [% handler_method %] 1697[% END %] 1698EO_TT_blocks 1699 1700#----------------------------------------------------------------- 1701# Methods in the B::C::Gantry package 1702#----------------------------------------------------------------- 1703 1704sub what_do_you_make { 1705 return [ 1706 [ 'lib/AppName.pm' => 'Base module stub [safe to change]' ], 1707 [ 'lib/AppName/*.pm' => 'Controller stubs [safe to change]' ], 1708 [ 'lib/AppName/GEN/*.pm' => 'Generated code [please, do not edit]' ], 1709 ]; 1710} 1711 1712sub backend_block_keywords { 1713 return [ 1714 { keyword => 'no_gen', 1715 label => 'No Gen', 1716 descr => 'Skip everything for this backend', 1717 type => 'boolean' }, 1718 1719 { keyword => 'run_test', 1720 label => 'Run Tests', 1721 descr => 'Makes tests which hit pages via a simple server', 1722 type => 'boolean', 1723 default => 'true' }, 1724 1725 { keyword => 'full_use', 1726 label => 'Full Use Statement', 1727 descr => 'use Gantry qw( -Engine=... ); [defaults to false]', 1728 type => 'boolean', 1729 default => 'false' }, 1730 1731 { keyword => 'dbix', 1732 label => 'For use with DBIx::Class', 1733 descr => 'Makes controllers usable with DBIx::Class', 1734 type => 'boolean', 1735 default => 'false' }, 1736 1737 { keyword => 'template', 1738 label => 'Alternate Template', 1739 descr => 'A custom TT template.', 1740 type => 'text' }, 1741 ]; 1742} 1743 1744sub setup_template { 1745 my $class = shift; 1746 my $template_text = shift || $default_template_text; 1747 1748 return if ( $template_is_setup ); 1749 1750 Inline->bind( 1751 TT => $template_text, 1752 POST_CHOMP => 1, 1753 TRIM_LEADING_SPACE => 0, 1754 TRIM_TRAILING_SPACE => 0, 1755 ); 1756 1757 $template_is_setup = 1; 1758} 1759 1760sub gen_Control { 1761 my $class = shift; 1762 my $build_dir = shift; 1763 my $bigtop_tree = shift; 1764 1765 my $app_name = $bigtop_tree->get_appname(); 1766 my $lookup = $bigtop_tree->{application}{lookup}; 1767 my $app_stmnts = $lookup->{app_statements}; 1768 my $authors = $bigtop_tree->get_authors(); 1769 my $contact_us = $bigtop_tree->get_contact_us(); 1770 my @external_modules; 1771 my $copyright_holder = $bigtop_tree->get_copyright_holder(); 1772 my $license_text = $bigtop_tree->get_license_text(); 1773 my $config = $bigtop_tree->get_config(); 1774 my $config_block = $config->{Control}; 1775 1776 my $full_use_statement = 0; 1777 if ( defined $config_block->{full_use} and $config_block->{full_use} ) { 1778 $full_use_statement = 1; 1779 } 1780 1781 @external_modules = @{ $app_stmnts->{uses} } 1782 if defined ( $app_stmnts->{uses} ); 1783 1784 my $year = ( localtime )[5]; 1785 $year += 1900; 1786 1787 my ( $module_dir, @sub_dirs ) 1788 = Bigtop::make_module_path( $build_dir, $app_name ); 1789 1790 # First, make one controller for each controller block in the bigtop_file 1791 # collect the names of all the controllers and their models. 1792 my $sub_modules = $bigtop_tree->walk_postorder( 1793 'output_controllers', 1794 { 1795 module_dir => $module_dir, 1796 app_name => $app_name, 1797 lookup => $lookup, 1798 tree => $bigtop_tree, 1799 authors => $authors, 1800 contact_us => $contact_us, 1801 copyright_holder => $copyright_holder, 1802 license_text => $license_text, 1803 year => $year, 1804 sub_modules => undef, 1805 }, 1806 ); 1807 1808 # Second, make the main modules. 1809 my $app_configs = $bigtop_tree->{application}{lookup}{configs}; 1810 my $config_values = $bigtop_tree->get_app_configs; 1811 my $base_controller = $bigtop_tree->walk_postorder( 'base_controller' ); 1812 1813 my ( $all_configs, $accessor_configs ) 1814 = build_config_lists( $app_configs, $config_values ); 1815 1816 my $config_accessors = 1817 Bigtop::Backend::Control::Gantry::config_accessors( 1818 { configs => $accessor_configs, } 1819 ); 1820 1821 my @pod_methods = map { $_, "set_$_" } @{ $accessor_configs }; 1822 1823 my $init_sub = build_init_sub( $accessor_configs ); 1824 1825 # now form nav links 1826 my $location = $bigtop_tree->walk_postorder( 'output_location' )->[0]; 1827 my $nav_links = $bigtop_tree->walk_postorder( 1828 'output_nav_links', $location 1829 ); 1830 1831 my @pages; 1832 foreach my $nav_link ( @{ $nav_links } ) { 1833 my %nav_pair = @{ $nav_link }; 1834 push @pages, \%nav_pair; 1835 } 1836 1837 my( $base_model, $dbix ) = ( '', '' ); 1838 if ( $config_block->{ dbix } ) { 1839 $base_model = $app_name . '::Model'; 1840 $dbix = 1; 1841 } 1842 1843 if ( defined $base_controller->[0] and $base_controller->[0] ) { 1844 # warn "skipping previously generated modules\n"; 1845 $bigtop_tree->walk_postorder( 1846 'output_controllers', 1847 { 1848 module_dir => $module_dir, 1849 app_name => $app_name, 1850 lookup => $lookup, 1851 tree => $bigtop_tree, 1852 authors => $authors, 1853 contact_us => $contact_us, 1854 copyright_holder => $copyright_holder, 1855 license_text => $license_text, 1856 year => $year, 1857 sub_modules => $sub_modules, 1858 full_use_statement => $full_use_statement, 1859 init_sub => $init_sub, 1860 config_accessors => $config_accessors, 1861 dbix => $dbix, 1862 base_model => $base_model, 1863 methods => \@pod_methods, 1864 pages => \@pages, 1865 %{ $config }, 1866 }, 1867 ); 1868 } 1869 else { # spoof up a base_controller block, if they don't provide one 1870 my $base_module_name = pop @sub_dirs; 1871 my $base_module_file = File::Spec->catfile( 1872 $build_dir, 'lib', @sub_dirs, "$base_module_name.pm" 1873 ); 1874 my $gen_base_module_name = "GEN$base_module_name"; 1875 my $gen_base_module_file = File::Spec->catfile( 1876 $build_dir, 'lib', @sub_dirs, "$gen_base_module_name.pm" 1877 ); 1878 my $gen_package_name = join '::', @sub_dirs, $gen_base_module_name; 1879 1880 # remember the pod 1881 1882 unshift @pod_methods, qw( namespace init do_main site_links ); 1883 1884 if ( $config_block->{ dbix } ) { 1885 unshift @pod_methods, 'schema_base_class'; 1886 } 1887 1888 my $pod = Bigtop::Backend::Control::Gantry::pod( 1889 { 1890 package_name => $app_name, 1891 gen_package_name => $gen_package_name, 1892 methods => \@pod_methods, 1893 other_module_text=> 'SEE ALSO', 1894 used_modules => [ 'Gantry', 1895 $gen_package_name, 1896 @{ $sub_modules } ], 1897 authors => $authors, 1898 contact_us => $contact_us, 1899 copyright_holder => $copyright_holder, 1900 license_text => $license_text, 1901 sub_module => 0, 1902 year => $year, 1903 } 1904 ); 1905 1906 my $base_module_content = 1907 Bigtop::Backend::Control::Gantry::base_module( 1908 { 1909 dist_name => $base_module_name, 1910 app_name => $app_name, 1911 gen_package_name => $gen_package_name, 1912 external_modules => \@external_modules, 1913 sub_modules => $sub_modules, 1914 init_sub => $init_sub, 1915 config_accessors => $config_accessors, 1916 pod => $pod, 1917 full_use_statement => $full_use_statement, 1918 pages => \@pages, 1919 %{ $config }, # Go fish! 1920 } 1921 ); 1922 1923 eval { 1924 no warnings qw( Bigtop ); 1925 Bigtop::write_file( 1926 $base_module_file, $base_module_content, 'no_overwrite' 1927 ); 1928 }; 1929 warn $@ if ( $@ ); 1930 1931 my $gen_pod = Bigtop::Backend::Control::Gantry::gen_pod( 1932 { 1933 package_name => $app_name, 1934 gen_package_name => $gen_package_name, 1935 methods => \@pod_methods, 1936 other_module_text=> 'SEE ALSO', 1937 used_modules => [ 'Gantry', 1938 $gen_package_name, 1939 @{ $sub_modules } ], 1940 authors => $authors, 1941 contact_us => $contact_us, 1942 copyright_holder => $copyright_holder, 1943 license_text => $license_text, 1944 sub_module => 0, 1945 year => $year, 1946 } 1947 ); 1948 1949 my $gen_base_content = 1950 Bigtop::Backend::Control::Gantry::gen_base_module( 1951 { 1952 dist_name => $base_module_name, 1953 app_name => $app_name, 1954 gen_package_name => $gen_package_name, 1955 external_modules => \@external_modules, 1956 sub_modules => $sub_modules, 1957 init_sub => $init_sub, 1958 config_accessors => $config_accessors, 1959 gen_pod => $gen_pod, 1960 full_use_statement => $full_use_statement, 1961 dbix => $dbix, 1962 base_model => $base_model, 1963 pages => \@pages, 1964 %{ $config }, # Go fish! 1965 } 1966 ); 1967 1968 eval { 1969 no warnings qw( Bigtop ); 1970 Bigtop::write_file( $gen_base_module_file, $gen_base_content ); 1971 }; 1972 warn $@ if ( $@ ); 1973 } 1974 1975 # finally, make the tests 1976 # start with the use test (compile test for all controllers) 1977 my $test_dir = File::Spec->catdir( $build_dir, 't' ); 1978 my $test_file = File::Spec->catfile( $test_dir, '01_use.t' ); 1979 1980 mkdir $test_dir; 1981 1982 unshift @{ $sub_modules }, $app_name; 1983 1984 my $module_count = @{ $sub_modules }; 1985 1986 my $test_file_content = Bigtop::Backend::Control::Gantry::test_file( 1987 { 1988 modules => $sub_modules, 1989 module_count => $module_count, 1990 } 1991 ); 1992 1993 eval { Bigtop::write_file( $test_file, $test_file_content ); }; 1994 warn $@ if ( $@ ); 1995 1996 # now make the pod and pod coverage tests 1997 my $pod_test_file = File::Spec->catfile( $test_dir, '02_pod.t' ); 1998 my $pod_cover_test_file = File::Spec->catfile( 1999 $test_dir, '03_podcover.t' 2000 ); 2001 2002 my $pod_test_content = 2003 Bigtop::Backend::Control::Gantry::pod_test( {} ); 2004 my $pod_cover_test_content = 2005 Bigtop::Backend::Control::Gantry::pod_cover_test( {} ); 2006 2007 eval { 2008 no warnings qw( Bigtop ); 2009 Bigtop::write_file( 2010 $pod_test_file, $pod_test_content, 'no overwrite' 2011 ); 2012 }; 2013 warn $@ if ( $@ ); 2014 2015 eval { 2016 no warnings qw( Bigtop ); 2017 Bigtop::write_file( 2018 $pod_cover_test_file, $pod_cover_test_content, 'no overwrite' 2019 ); 2020 }; 2021 warn $@ if ( $@ ); 2022 2023 # finally, make the run test, unless they asked not to 2024 if ( not defined $config_block->{ run_test } 2025 or 2026 $config_block->{ run_test } ) 2027 { 2028 2029 # ...first, prepare the configs 2030 my @configs; 2031 my $saw_root = 0; 2032 2033 APP_CONFIG: 2034 foreach my $var ( sort keys %{ $config_values->{ base } } ) { 2035 2036 next APP_CONFIG if $var eq 'dbconn'; 2037 2038 my $value = $config_values->{ base }{ $var }; 2039 if ( ref $value ) { 2040 ( $value ) = keys %{ $value }; 2041 } 2042 push @configs, [ $var, $value ]; 2043 2044 $saw_root++ if $var eq 'root'; 2045 } 2046 unshift @configs, [ 'dbconn', 'dbi:SQLite:dbname=app.db' ]; 2047 push @configs, [ 'root', 'html:html/templates' ] unless $saw_root; 2048 2049 # ...then, the locations 2050 my $locations = $bigtop_tree->walk_postorder( 2051 'output_test_locations', $lookup 2052 ); 2053 my $num_tests = @{ $locations }; 2054 2055 my $run_test_file = File::Spec->catfile( $test_dir, '10_run.t' ); 2056 my $run_test_content = Bigtop::Backend::Control::Gantry::run_test( 2057 { 2058 app_name => $app_name, 2059 configs => \@configs, 2060 locations => $locations, 2061 num_tests => $num_tests, 2062 %{ $config }, # fish for template engine name 2063 } 2064 ); 2065 2066 eval { 2067 no warnings qw( Bigtop ); 2068 Bigtop::write_file( 2069 $run_test_file, $run_test_content, 2070 ); 2071 }; 2072 warn $@ if ( $@ ); 2073 2074 } 2075} 2076 2077sub build_init_sub { 2078 my $configs = shift; 2079 2080 my $arg_capture = 2081 Bigtop::Backend::Control::Gantry::arg_capture_st_nick_style( 2082 { args => [ qw( $self $r ) ] } 2083 ); 2084 2085 my $body = Bigtop::Backend::Control::Gantry::init_method_body( 2086 { 2087 arg_capture => $arg_capture, 2088 configs => $configs, 2089 } 2090 ); 2091 2092 my $method = Bigtop::Backend::Control::Gantry::gen_controller_method( 2093 { 2094 method_name => 'init', 2095 child_output => { 2096 body => $body, 2097 doc_args => [ '$r' ], 2098 }, 2099 } 2100 ); 2101 2102 $method =~ s/^\s+//; 2103 $method =~ s/^/#/gm if ( @{ $configs } == 0 ); # no configs, comment it out 2104 2105 return "$method\n"; 2106} 2107 2108sub build_config_lists { 2109 my $app_configs = shift; 2110 my $config_values = shift; 2111 2112 my @accessor_configs; 2113 my @all_configs; 2114 2115 SET_VAR: 2116 foreach my $config ( keys %{ $app_configs } ) { 2117 2118 if ( defined $config_values ) { 2119 next SET_VAR unless defined $config_values->{ base }{ $config }; 2120 } 2121 2122 push @all_configs, $config; 2123 2124 my $item = $app_configs->{$config}[0]; 2125 2126 if ( ref( $item ) =~ /HASH/ ) { 2127 2128 my ( $value, $condition ) = %{ $item }; 2129 2130 next SET_VAR if $condition eq 'no_accessor'; 2131 } 2132 2133 push @accessor_configs, $config; 2134 } 2135 2136 return \@all_configs, \@accessor_configs; 2137} 2138 2139#----------------------------------------------------------------- 2140# Packages named in the grammar 2141#----------------------------------------------------------------- 2142 2143package # application 2144 application; 2145use strict; use warnings; 2146 2147sub output_test_locations { 2148 my $self = shift; 2149 my $child_output = shift; 2150 my $lookup = shift; 2151 2152 my $app_name = $self->get_name(); 2153 my $base_location = '/'; 2154 2155 my @retval; 2156 2157 # we only skip the test if there is an explicit, true, skip test statement 2158 my $skip_base_test = 0; 2159 my $base_controller = $lookup->{ controllers }{ base_controller }; 2160 2161 if ( defined $base_controller ) { 2162 my $skip_test = $base_controller->{ statements }{ skip_test }; 2163 if ( defined $skip_test ) { 2164 $skip_base_test = $skip_test->[0]; 2165 } 2166 } 2167 2168 push @retval, [ $base_location, $app_name ] unless $skip_base_test; 2169 2170 while ( @{ $child_output } ) { 2171 my ( $loc_type ) = shift @{ $child_output }; 2172 2173 my $data = shift @{ $child_output }; 2174 my ( $location, $module ) = @{ $data }; 2175 2176 if ( $loc_type eq 'rel_location' ) { 2177 $location = $base_location . $location; 2178 } 2179 2180 $module = $app_name . '::' . $module; 2181 2182 push @retval, [ $location, $module ]; 2183 } 2184 2185 return \@retval; 2186} 2187 2188package # join_table 2189 join_table; 2190use strict; use warnings; 2191 2192sub output_field_names { 2193 my $self = shift; 2194 my $child_output = shift; 2195 my $data = shift; 2196 2197 return unless $self->{__NAME__} eq $data->{table_of_interest}; 2198 2199 return $child_output; 2200} 2201 2202package # table_block 2203 table_block; 2204use strict; use warnings; 2205 2206sub output_field_names { 2207 my $self = shift; 2208 my $child_output = shift; 2209 my $data = shift; 2210 2211 return unless $self->{__TYPE__} eq 'tables'; 2212 2213 return unless $self->{__NAME__} eq $data->{table_of_interest}; 2214 2215 return $child_output; 2216} 2217 2218package # table_element_block 2219 table_element_block; 2220use strict; use warnings; 2221 2222sub output_field_names { 2223 my $self = shift; 2224 2225 return unless $self->{__TYPE__} eq 'field'; 2226 2227 return [ $self->{__NAME__} ]; 2228} 2229 2230package # controller_block 2231 controller_block; 2232use strict; use warnings; 2233 2234use Bigtop; 2235 2236my %magical_uses = ( 2237 CRUD => 'Gantry::Plugins::CRUD', 2238 AutoCRUD => 'Gantry::Plugins::AutoCRUD', 2239 stub => '', 2240); 2241my %magical_gen_uses = ( 2242# SOAP => 'Gantry::Plugins::SOAP::RPCMP', 2243); 2244 2245sub get_package_name { 2246 my $self = shift; 2247 my $data = shift; 2248 2249 return $data->{app_name} . '::' . $self->get_name(); 2250} 2251 2252sub get_gen_package_name { 2253 my $self = shift; 2254 my $data = shift; 2255 2256 if ( $self->is_base_controller ) { 2257 my @pieces = split /::/, $data->{ app_name }; 2258 my $module_name = 'GEN' . pop @pieces; 2259 return join '::', @pieces, $module_name; 2260 } 2261 else { 2262 return $data->{app_name} . '::GEN::' . $self->get_name(); 2263 } 2264} 2265 2266# this on is for walk_postorder use 2267sub base_controller { 2268 my $self = shift; 2269 2270 return [ 1 ] if ( $self->is_base_controller ); 2271} 2272 2273sub skip_base_controller { 2274 my $self = shift; 2275 2276 return unless $self->is_base_controller; 2277 2278 #warn "I'm the base controller\n"; 2279 2280 return; 2281} 2282 2283sub output_extra_use { 2284 my $self = shift; 2285 my $type = shift; 2286 my $module = $magical_uses{ $type } || return; 2287 2288 my $poser = { 2289 __ARGS__ => [ $module ] 2290 }; 2291 bless $poser, 'controller_statement'; 2292 2293 my %extra_use = @{ $poser->uses }; 2294 2295 my $output = $extra_use{ uses_output }; 2296 2297 return ( $output, $module ); 2298} 2299 2300sub output_extra_gen_use { 2301 my $self = shift; 2302 my $type = shift; 2303 my $module = $magical_gen_uses{ $type } || return; 2304 2305 my $poser = { 2306 __ARGS__ => [ $module ] 2307 }; 2308 bless $poser, 'controller_statement'; 2309 2310 my %extra_use = @{ $poser->uses }; 2311 2312 my $output = $extra_use{ uses_output }; 2313 2314 return ( $output, $module ); 2315} 2316 2317sub output_controllers { 2318 my $self = shift; 2319 shift; 2320 my $data = shift; 2321 2322 if ( $self->is_base_controller ) { # if its the base, we need the subs 2323 return unless defined $data->{ sub_modules }; 2324 } 2325 else { # if we have the subs, we don't need them again 2326 return if defined $data->{ sub_modules }; 2327 } 2328 2329 my $model_alias = $self->walk_postorder( 'get_model_alias' )->[0]; 2330 2331 $data->{ model_alias } = $model_alias; 2332 2333 my $child_output = $self->walk_postorder( 'output_controller', $data ); 2334 2335 # generate the content of the controller and its GEN module 2336 my $short_name = $self->get_name(); 2337 my $package_name = $self->get_package_name( $data ); 2338 my $gen_package_name = $self->get_gen_package_name( $data ); 2339 2340 # skip it if we can 2341 my $statements = $data->{lookup}{controllers}{$short_name}{statements}; 2342 2343 return if ( defined $statements->{no_gen} and $statements->{no_gen}[0] ); 2344 2345 # Begin by inserting magical things based on controller type 2346 my $controller_type = $self->get_controller_type(); 2347 my ( $extra_use, $extra_module ) 2348 = $self->output_extra_use( $controller_type ); 2349 2350 my ( $gen_extra_use, $gen_extra_module ) 2351 = $self->output_extra_gen_use( $controller_type ); 2352 2353 ############################################# 2354 # Deal with what the children made for us. # 2355 ############################################# 2356 my ( $output_str, $class_access, $gen_output_str, $output_hash ) 2357 = _extract_output_from( $child_output ); 2358 2359 my $stub_method_names = $output_hash->{stub_method_name}; 2360 my $gen_method_names = $output_hash->{gen_method_name}; 2361 my $crud_doc_methods = $output_hash->{crud_doc_methods}; 2362 my $soap_style = _extract_soap_style( 2363 $output_hash->{ soap_style } 2364 ); 2365 2366 # gen_method_names is an array ref of names or undef if there are none 2367 2368 # build beginning of dependencies section (the base app and the GEN 2369 # if it has methods) 2370 my @depend_head = ( $data->{app_name} ) 2371 unless ( $self->is_base_controller ); 2372 2373 push @depend_head, $gen_package_name 2374 if ( defined $gen_method_names 2375 or 2376 defined $output_hash->{ extra_stub_method_name } 2377 ); 2378 2379 unshift @{ $output_hash->{used_modules} }, \@depend_head; 2380 2381 my $used_modules = _flatten( $output_hash->{used_modules} ); 2382 2383 if ( $extra_use ) { 2384 push @{ $used_modules }, $extra_module; 2385 chomp $extra_use; 2386 $output_str = "\n$extra_use" . $output_str; 2387 } 2388 2389 if ( $gen_extra_use ) { 2390 push @{ $used_modules }, $gen_extra_module; 2391 chomp $gen_extra_use; 2392 $gen_output_str = "\n$gen_extra_use" . $gen_output_str; 2393 } 2394 2395 # deal with SOAP rpc stubs 2396 if ( defined $output_hash->{ extra_stub_method_name } ) { 2397 push @{ $stub_method_names }, 2398 @{ $output_hash->{ extra_stub_method_name } }; 2399 } 2400 2401 # ... and SOAP wsdl method 2402 my $wsdl; 2403 if ( defined $output_hash->{ soap_params } ) { 2404 $wsdl = Bigtop::Backend::Control::Gantry::soap_methods( 2405 { 2406 operations => $output_hash->{ soap_params }, 2407 soap_name => $statements->{ soap_name }[0], 2408 namespace_base => $statements->{ namespace_base }[0], 2409 stub_module => $package_name, 2410 } 2411 ); 2412 if ( $wsdl ) { 2413 push @{ $gen_method_names }, qw( namespace get_soap_ops ); 2414 } 2415 } 2416 2417 # make doc stubs for standard controller accessor methods 2418 if ( defined $statements->{controls_table} ) { 2419 push @{ $stub_method_names }, qw( get_model_name text_descr ); 2420 } 2421 2422 my $config_block = $data->{ tree }->get_config()->{ Control }; 2423 if ( $config_block->{ dbix } ) { 2424 2425 push @{ $stub_method_names }, qw( get_orm_helper ); 2426 2427 if ( $self->is_base_controller ) { 2428 push @{ $gen_method_names }, qw( schema_base_class ); 2429 } 2430 } 2431 2432 # make the gen use statement if it has methods 2433 my $gen_use_statement; 2434 if ( defined $gen_method_names ) { 2435 $gen_use_statement = Bigtop::Backend::Control::Gantry::use_stub( 2436 { module => $gen_package_name, imports => $gen_method_names } 2437 ); 2438 } 2439 2440 my $export_array = Bigtop::Backend::Control::Gantry::export_array( 2441 { exported_subs => $gen_method_names } 2442 ); 2443 2444 my $loc_configs = $data->{lookup}{controllers}{$short_name}{configs}; 2445 my ( $all_configs, $accessor_configs ) = 2446 Bigtop::Backend::Control::Gantry::build_config_lists( 2447 $loc_configs 2448 ); 2449 2450 my $init_sub; 2451 if ( @{ $accessor_configs } ) { 2452 $init_sub = Bigtop::Backend::Control::Gantry::build_init_sub( 2453 $accessor_configs 2454 ); 2455 } 2456 2457 my $config_accessors; 2458 if ( @{ $accessor_configs } ) { 2459 $config_accessors = Bigtop::Backend::Control::Gantry::config_accessors( 2460 { configs => $accessor_configs, } 2461 ); 2462 } 2463 2464 my $inherit_from; 2465 my $other_module_text = 'DEPENDENCIES'; 2466 2467 my @pack_pieces; 2468 my $base_name; 2469 2470 if ( $self->is_base_controller ) { 2471 @pack_pieces = split /::/, $data->{ app_name }; 2472 $base_name = pop @pack_pieces; 2473 $base_name .= '.pm'; 2474 2475 $inherit_from = 'Gantry'; # only a default 2476 $other_module_text = 'SEE ALSO'; 2477 2478 $package_name = $data->{ app_name }; 2479 $used_modules = [ 'Gantry' ]; 2480 if ( $gen_method_names ) { 2481 push @{ $used_modules }, $gen_package_name; 2482 } 2483 # now push in any modules from uses statements 2484 } 2485 else { 2486 @pack_pieces = split /::/, $short_name; 2487 $base_name = pop @pack_pieces; 2488 $base_name .= '.pm'; 2489 2490 $inherit_from = $data->{ app_name }; 2491 } 2492 2493 if ( defined $gen_method_names ) { # in either case, use GEN if available 2494 $inherit_from = $gen_package_name; 2495 } 2496 2497 my $all_gen_methods = $gen_method_names; 2498 2499 if ( $data->{ init_sub } ) { 2500 # unshift has side effect of defining array if not defined 2501 unshift @{ $gen_method_names }, qw( namespace init ); 2502 2503 $all_gen_methods = [ 2504 @{ $gen_method_names }, 2505 @{ $data->{ methods } }, 2506 ]; 2507 } 2508 2509 if ( defined $crud_doc_methods ) { 2510 foreach my $method_set ( @{ $crud_doc_methods } ) { 2511 push @{ $stub_method_names }, @{ $method_set }; 2512 } 2513 } 2514 2515 if ( not $self->is_base_controller() 2516 and 2517 defined $statements->{plugins} and $statements->{plugins}[0] 2518 ) { 2519 push @{ $all_gen_methods }, 'namespace'; 2520 } 2521 2522 my $pod = Bigtop::Backend::Control::Gantry::pod( 2523 { 2524 app_name => $data->{app_name}, 2525 accessors => $accessor_configs, 2526 package_name => $package_name, 2527 methods => $stub_method_names, 2528 gen_package_name => 2529 ( defined $all_gen_methods ) ? $gen_package_name : undef, 2530 mixins => $all_gen_methods, 2531 other_module_text=> $other_module_text, 2532 used_modules => $used_modules, 2533 authors => $data->{authors}, 2534 contact_us => $data->{contact_us}, 2535 copyright_holder => $data->{copyright_holder}, 2536 license_text => $data->{license_text}, 2537 sub_module => ( not $self->is_base_controller ), 2538 sub_modules => $data->{sub_modules}, 2539 year => $data->{year}, 2540 } 2541 ); 2542 2543 my $output; 2544 my $gen_pod; 2545 my $gen_output; 2546 2547 if ( $self->is_base_controller ) { 2548 $output = Bigtop::Backend::Control::Gantry::base_module( 2549 { 2550 package_name => $package_name, 2551 gen_package_name => $inherit_from, 2552 gen_use_statement => $gen_use_statement, 2553 child_output => $output_str, 2554 class_accessors => $class_access, 2555 pod => $pod, 2556 config_accessors => $config_accessors, 2557 %{ $data }, 2558 } 2559 ); 2560 $gen_pod = 2561 Bigtop::Backend::Control::Gantry::gen_pod( 2562 { 2563 package_name => $data->{ app_name }, 2564 gen_package_name => $gen_package_name, 2565 other_module_text=> 'SEE ALSO', 2566 used_modules => [ 'Gantry', 2567 $gen_package_name, 2568 @{ $data->{ sub_modules } } ], 2569 sub_module => 0, 2570 %{ $data }, 2571 methods => $all_gen_methods, 2572 } 2573 # these are in $data: authors, contact_ud, copyright_holder, 2574 # license_text, year, and app_name 2575 ); 2576 $gen_output = Bigtop::Backend::Control::Gantry::gen_base_module( 2577 { 2578 child_output => $gen_output_str, 2579 gen_package_name => $gen_package_name, 2580 init_sub => $init_sub, 2581 config_accessors => $config_accessors, 2582 gen_pod => $gen_pod, 2583 %{ $data }, # Go fish! 2584 } 2585 ); 2586 } 2587 else { 2588 # deal with non-base controller plugins 2589 2590 my $plugins; 2591 if ( defined $statements->{plugins} and $statements->{plugins}[0] ) { 2592 $plugins = join ', ', @{ $statements->{plugins} }; 2593 } 2594 2595 if ( $plugins ) { 2596 my $config = $data->{ tree }->get_config(); 2597 my $app_level_plugins = $config->{ plugins }; 2598 $plugins = "$app_level_plugins $plugins" 2599 if $app_level_plugins; 2600 2601 $inherit_from = $gen_package_name; 2602 } 2603 2604 $output = Bigtop::Backend::Control::Gantry::controller_block( 2605 { 2606 app_name => $data->{app_name}, 2607 package_name => $package_name, 2608 inherit_from => $inherit_from, 2609 gen_use_statement => $gen_use_statement, 2610 child_output => $output_str, 2611 class_accessors => $class_access, 2612 pod => $pod, 2613 sub_modules => $data->{sub_modules}, 2614 wsdl => $wsdl, 2615 soap_style => $soap_style, 2616 } 2617 ); 2618 2619 $gen_pod = 2620 Bigtop::Backend::Control::Gantry::gen_controller_pod( 2621 { 2622 package_name => $package_name, 2623 gen_package_name => 2624 ( defined $all_gen_methods ) ? $gen_package_name : undef, 2625 gen_methods => $all_gen_methods, 2626 sub_module => 1, 2627 } 2628 ); 2629 2630 $gen_output = Bigtop::Backend::Control::Gantry::gen_controller_block( 2631 { 2632 app_name => $data->{app_name}, 2633 gen_package_name => $gen_package_name, 2634 package_name => $package_name, 2635 child_output => $gen_output_str, 2636 export_array => $export_array, 2637 gen_pod => $gen_pod, 2638 wsdl => $wsdl, 2639 soap_style => $soap_style, 2640 plugins => $plugins, 2641 config_accessors => $config_accessors, 2642 init_sub => $init_sub, 2643 } 2644 ); 2645 } 2646 2647 my $pm_file; 2648 my $gen_pm_file; 2649 my $retval; 2650 2651 # put the content onto the disk 2652 if ( $self->is_base_controller ) { 2653 2654 my $module_dir = $data->{ module_dir }; 2655 2656 # Example: module_dir = t/gantry/play/Apps-Checkbook/lib/Apps/Checkbook 2657 # we want to strip off the last dir and put our module names there: 2658 # t/gantry/play/Apps-Checkbook/lib/Apps/Checkbook.pm 2659 # t/gantry/play/Apps-Checkbook/lib/Apps/GENCheckbook.pm 2660 my @module_dir_pieces = File::Spec->splitdir( $module_dir ); 2661 pop @module_dir_pieces; 2662 my $base_module_dir = File::Spec->catdir( @module_dir_pieces ); 2663 2664 mkdir $base_module_dir; 2665 2666 $pm_file = File::Spec->catfile( $base_module_dir, $base_name ); 2667 $gen_pm_file = File::Spec->catfile( 2668 $base_module_dir, "GEN$base_name" 2669 ); 2670 2671 $retval = []; 2672 } 2673 else { 2674 2675 # ... first make sure the directories exist for this piece 2676 my $module_home = File::Spec->catdir( $data->{module_dir} ); 2677 foreach my $subdir ( @pack_pieces ) { 2678 $module_home = File::Spec->catdir( $module_home, $subdir ); 2679 mkdir $module_home; 2680 } 2681 2682 # ... then make sure GEN directories exist (similar plan) 2683 my $gen_home = File::Spec->catdir( $data->{module_dir}, 'GEN' ); 2684 2685 if ( defined $all_gen_methods ) { 2686 mkdir $gen_home; 2687 2688 foreach my $subdir ( @pack_pieces ) { 2689 $gen_home = File::Spec->catdir( $gen_home, $subdir ); 2690 mkdir $gen_home; 2691 } 2692 } 2693 2694 $pm_file = File::Spec->catfile( $module_home, $base_name); 2695 $gen_pm_file = File::Spec->catfile( $gen_home, $base_name); 2696 2697 $retval = [ $package_name ]; 2698 } 2699 2700 # ... then write them 2701 eval { 2702 # Is the stub already present? Then skip it. 2703 no warnings qw( Bigtop ); 2704 Bigtop::write_file( $pm_file, $output, 'no overwrite' ); 2705 if ( defined $all_gen_methods ) { 2706 Bigtop::write_file( $gen_pm_file, $gen_output ); 2707 } 2708# else { 2709# warn "no gen to write $gen_pm_file\n"; 2710# warn $gen_output; 2711# } 2712 }; 2713 return if ( $@ ); 2714 2715 # tell postorder walker what we just built 2716 return $retval; 2717} 2718 2719sub _flatten { 2720 my $input = shift; 2721 2722 my @output; 2723 2724 foreach my $element ( @{ $input } ) { 2725 push @output, @{ $element }; 2726 } 2727 2728 return \@output; 2729} 2730 2731sub _extract_output_from { 2732 my $child_output = shift; 2733 2734 my %all_output; 2735 2736 # extract from the individual child output lists 2737 foreach my $output_list ( @{ $child_output } ) { 2738 my $output_hash = { @{ $output_list } }; 2739 2740 foreach my $type ( keys %{ $output_hash } ) { 2741 next unless defined $output_hash->{ $type }; 2742 push @{ $all_output{ $type } }, $output_hash->{ $type }; 2743 } 2744 } 2745 2746 # join the results 2747 my $empty_string = ''; 2748 my $output = $empty_string; 2749 my $class_access = $empty_string; 2750 my $gen_output = $empty_string; 2751 2752 # make sure uses are near the top 2753 if ( defined $all_output{uses_output} ) { 2754 $output .= join $empty_string, @{ $all_output{uses_output} }; 2755 } 2756 2757 if ( defined $all_output{uses_gen_output} ) { 2758 $gen_output .= join $empty_string, @{ $all_output{uses_gen_output} }; 2759 } 2760 2761 # then get the rest 2762 if ( defined $all_output{output} ) { 2763 $output .= join $empty_string, @{ $all_output{output} }; 2764 } 2765 2766 if ( defined $all_output{gen_output} ) { 2767 $gen_output .= join $empty_string, @{ $all_output{gen_output} }; 2768 } 2769 2770 if ( defined $all_output{class_access} ) { 2771 $class_access .= join $empty_string, @{ $all_output{class_access} }; 2772 } 2773 2774 return ( 2775 $output, 2776 $class_access, 2777 $gen_output, 2778 \%all_output, 2779 ); 2780} 2781 2782sub _extract_soap_style { 2783 my $soap_styles = shift; 2784 2785 return unless ref $soap_styles eq 'ARRAY'; 2786 2787 my %soap_styles = map { $_ => 1 } @{ $soap_styles }; 2788 2789 if ( keys %soap_styles > 1 ) { 2790 die "Mixing SOAP styles is not supported by Bigtop.\n"; 2791 } 2792 else { 2793 return 'RPC' if defined $soap_styles{ 'SOAP' }; 2794 return 'Doc' if defined $soap_styles{ 'SOAPDoc' }; 2795 return undef; 2796 } 2797} 2798 2799sub output_nav_links { 2800 my $self = shift; 2801 my $child_output = shift; 2802 my $base_location = shift || ''; 2803 2804 my %retval = @{ $child_output }; 2805 2806 if ( defined $retval{ label } and $retval{ label } ) { 2807 2808 if ( $self->is_base_controller ) { 2809 push @{ $child_output }, 'link', $base_location; 2810 } 2811 2812 return [ $child_output ]; 2813 } 2814 else { 2815 return []; 2816 } 2817} 2818 2819sub output_test_locations { 2820 my $self = shift; 2821 my $child_output = shift; 2822 my $lookup = shift; 2823 2824 return if ( $self->is_base_controller ); 2825 2826 my %child_output = @{ $child_output}; 2827 2828 my @keys = keys %{ $self }; 2829 2830 my $controller_statements = $lookup->{ controllers } 2831 { $self->{__NAME__} } 2832 { statements }; 2833 2834 if ( defined $controller_statements->{ skip_test} 2835 and 2836 $controller_statements->{ skip_test} 2837 ) { 2838 return; 2839 } 2840 2841 my @retval; 2842 2843 # add my name to the data going up 2844 foreach my $loc_type ( keys %child_output ) { 2845 push @retval, 2846 $loc_type => [ 2847 $child_output{ $loc_type } => $self->{ __NAME__ } 2848 ]; 2849 } 2850 2851 return \@retval; 2852} 2853 2854# controller_statement 2855 2856package # controller_statement 2857 controller_statement; 2858use strict; use warnings; 2859 2860sub output_controller { 2861 my $self = shift; 2862 my $child_output = shift; 2863 my $data = shift; 2864 2865 my $keyword = $self->{__KEYWORD__}; 2866 2867 return unless Bigtop::Backend::Control->is_controller_keyword( $keyword ); 2868 2869 return [ $self->$keyword( $child_output, $data ) ]; 2870} 2871 2872sub _form_uses { 2873 my $self = shift; 2874 2875 my @output; 2876 my @used_modules; 2877 2878 foreach my $module ( @{ $self->{__ARGS__} } ) { 2879 2880 if ( ref( $module ) eq 'HASH' ) { 2881 my ( $used, $import ) = %{ $module }; 2882 my $use_statement = 2883 Bigtop::Backend::Control::Gantry::explicit_use_stub( 2884 { 2885 module => $used, 2886 import_list => $import, 2887 } 2888 ); 2889 chomp $use_statement; 2890 push @output, $use_statement; 2891 $module = $used; 2892 } 2893 2894 else { 2895 my @exported; 2896 eval { 2897 my $module_path = $module; 2898 $module_path =~ s{::}{/}g; 2899 require "$module_path.pm"; 2900 }; 2901 2902 if ( $@ ) { 2903 push @output, Bigtop::Backend::Control::Gantry::use_stub( 2904 { module => $module, } 2905 ); 2906 } 2907 else { 2908 { 2909 no strict 'refs'; 2910 @exported = @{"$module\::EXPORT"}; 2911 } 2912 if ( @exported ) { 2913 push @output, Bigtop::Backend::Control::Gantry::use_stub( 2914 { module => $module, imports => \@exported } 2915 ); 2916 } 2917 else { 2918 push @output, Bigtop::Backend::Control::Gantry::use_stub( 2919 { module => $module } 2920 ); 2921 } 2922 } 2923 } 2924 2925 push @used_modules, $module; 2926 } 2927 2928 my $output = join "\n", @output; 2929 $output .= "\n\n"; 2930 2931 return $output, \@used_modules; 2932} 2933 2934sub uses { 2935 my $self = shift; 2936 2937 my ( $output, $used_modules ) = $self->_form_uses(); 2938 2939 return [ 2940 uses_output => $output, 2941 uses_gen_output => $output, 2942 used_modules => $used_modules, 2943 ]; 2944} 2945 2946sub stub_uses { 2947 my $self = shift; 2948 2949 my ( $output, $used_modules ) = $self->_form_uses(); 2950 2951 return [ 2952 uses_output => $output, 2953 used_modules => $used_modules, 2954 ]; 2955} 2956 2957sub gen_uses { 2958 my $self = shift; 2959 2960 my ( $output, $used_modules ) = $self->_form_uses(); 2961 2962 return [ 2963 uses_gen_output => $output, 2964 used_modules => $used_modules, 2965 ]; 2966} 2967 2968sub is_crud { 2969 my $self = shift; 2970 my $data = shift; 2971 2972 my $controller_name = $self->get_controller_name; 2973 my $controller_type = $data->{lookup} 2974 {controllers} 2975 {$controller_name} 2976 {type} 2977 || 'stub'; 2978 2979 return ( $controller_type eq 'CRUD' ); 2980} 2981 2982sub is_dbix_class { 2983 my $self = shift; 2984 my $data = shift; 2985 my $config_block = $data->{ tree }->get_config()->{ Control }; 2986 2987 return $config_block->{ dbix }; 2988} 2989 2990sub get_model_alias { 2991 my $self = shift; 2992 2993 return unless $self->{ __KEYWORD__ } eq 'controls_table'; 2994 2995 my $alias = uc $self->{ __ARGS__ }[0]; 2996 $alias =~ s/\./_/; 2997 2998 return [ $alias ]; 2999} 3000 3001sub controls_table { 3002 my $self = shift; 3003 my $child_output = shift; 3004 my $data = shift; 3005 my $table = $self->{__ARGS__}[0]; 3006 3007 $table =~ s/\./_/; 3008 3009 my $model = "$data->{app_name}\::Model::$table"; 3010 3011 my $model_alias = $data->{ model_alias }; 3012 3013 my $output = Bigtop::Backend::Control::Gantry::use_stub( 3014 { module => $model, imports => "\$$model_alias" } 3015 ); 3016 my $gen_output = $output; 3017 3018 my $class_access = ''; 3019 3020 unless ( $self->is_crud( $data ) ) { 3021 $class_access = Bigtop::Backend::Control::Gantry::class_access( 3022 { model_alias => $model_alias } 3023 ); 3024 3025 if ( $self->is_dbix_class( $data ) ) { 3026 my $helper = 'Gantry::Plugins::AutoCRUDHelper::DBIxClass'; 3027 my $controller = $self->get_controller_name(); 3028 3029 if ( defined $data->{ tree } 3030 { application } 3031 { lookup } 3032 { controllers } 3033 { $controller } 3034 { statements } 3035 { autocrud_helper } 3036 ) { 3037 $helper = $data->{tree} 3038 { application } 3039 { lookup } 3040 { controllers } 3041 { $controller } 3042 { statements } 3043 { autocrud_helper } 3044 [ 0 ]; 3045 } 3046 3047 $class_access .= 3048 Bigtop::Backend::Control::Gantry::get_orm_helper( 3049 { 3050 helper => $helper, 3051 } 3052 ); 3053 } 3054 } 3055 3056 # This use statement goes in both stub and gen output. 3057 return [ 3058 uses_output => $output, 3059 uses_gen_output => $gen_output, 3060 class_access => $class_access, 3061 used_modules => [ $model ], 3062 ]; 3063} 3064 3065sub text_description { 3066 my $self = shift; 3067 my $child_output = shift; 3068 my $data = shift; 3069 my $description = $self->{__ARGS__}[0]; 3070 3071 if ( $self->is_crud( $data ) ) { 3072 return; 3073 } 3074 else { 3075 my $output = Bigtop::Backend::Control::Gantry::text_description( 3076 { description => $description } 3077 ); 3078 3079 return [ 3080 class_access => $output, 3081 ]; 3082 } 3083} 3084 3085sub output_nav_links { 3086 my $self = shift; 3087 3088 if ( $self->{__KEYWORD__} eq 'rel_location' ) { 3089 return [ link => $self->{__ARGS__}->get_first_arg() ] 3090 } 3091 elsif ( $self->{__KEYWORD__} eq 'location' ) { 3092 return [ link => $self->{__ARGS__}->get_first_arg() ] 3093 } 3094 3095 if ( $self->{__KEYWORD__} eq 'page_link_label' ) { 3096 return [ label => $self->{__ARGS__}->get_first_arg() ] 3097 } 3098 3099 return []; 3100} 3101 3102sub output_test_locations { 3103 my $self = shift; 3104 3105 return unless ( $self->{ __KEYWORD__ } =~ /location/ ); 3106 3107 return [ $self->{ __KEYWORD__ } => $self->{ __ARGS__ }->get_first_arg, ]; 3108} 3109 3110package # controller_method 3111 controller_method; 3112use strict; use warnings; 3113 3114sub output_controller { 3115 my $self = shift; 3116 shift; # There's no child output, we're in the recursion base. 3117 my $data = shift; 3118 3119 my $gen_package_name 3120 = $self->{__PARENT__}->get_gen_package_name( $data ); 3121 3122 my $base_name = $gen_package_name; 3123 $base_name =~ s/.*:://; 3124 3125 my $method_name = $self->{__NAME__}; 3126 my $type = $self->{__TYPE__}; 3127 my $method_body = $self->{__BODY__}; 3128 3129 my $controller_statements 3130 = $data->{lookup} 3131 {controllers} 3132 {$base_name} 3133 {statements}; 3134 3135 my $statements = $data->{lookup} 3136 {controllers} 3137 {$base_name} 3138 {methods} 3139 {$method_name} 3140 {statements}; 3141 3142 return if ( $statements->{no_gen} ); 3143 3144 # restart recursion based on method type 3145 unless ( $method_body->can( "output_$type" ) ) { 3146 die "Error: bad type '$type' for method '$method_name'\n" 3147 . "in controller '$base_name'\n"; 3148 } 3149 3150 my $child_output = $method_body->walk_postorder( "output_$type", $data ); 3151 3152 if ( $child_output ) { 3153 $child_output = { @{ $child_output } }; 3154 } 3155 3156 my $stub_method_name; 3157 if ( $type eq 'stub' ) { 3158 $stub_method_name = $self->{__NAME__}; 3159 } 3160 elsif ( defined $child_output->{ stub_method_name } ) { 3161 $stub_method_name = $child_output->{ stub_method_name }; 3162 } 3163 3164 my $gen_method_name; 3165 if ( defined $child_output->{gen_output} 3166 and 3167 $child_output->{gen_output}{body} ) 3168 { 3169 $gen_method_name = $self->{__NAME__}; 3170 } 3171 3172 my ( $output, $gen_output ); 3173 3174 if ( $child_output->{gen_output} ) { 3175 $gen_output = Bigtop::Backend::Control::Gantry::gen_controller_method( 3176 { 3177 method_name => $self->{__NAME__}, 3178 child_output => $child_output->{gen_output}, 3179 } 3180 ); 3181 } 3182 3183 if ( $child_output->{comment_output} ) { 3184 $output = Bigtop::Backend::Control::Gantry::controller_method( 3185 { 3186 method_name => $self->{__NAME__}, 3187 child_output => $child_output->{comment_output}, 3188 gen_package_name => $gen_package_name, 3189 } 3190 ); 3191 } 3192 3193 if ( $child_output->{ extra_comment_methods } ) { 3194 foreach my $method ( @{ $child_output->{ extra_comment_methods } } ) { 3195 $output .= Bigtop::Backend::Control::Gantry::controller_method( 3196 { 3197 method_name => $method, 3198 gen_package_name => $gen_package_name, 3199 } 3200 ); 3201 } 3202 } 3203 3204 if ( $child_output->{stub_output} ) { 3205 $output .= Bigtop::Backend::Control::Gantry::gen_controller_method( 3206 { 3207 method_name => $self->{__NAME__}, 3208 child_output => $child_output->{stub_output}, 3209 } 3210 ); 3211 } 3212 3213 my $extra_stub_method; 3214 my $crud_doc_methods; 3215 3216 if ( $child_output->{ extra_for_stub } ) { 3217 $output .= "\n$child_output->{ extra_for_stub }{ full_sub }\n"; 3218 $extra_stub_method = $child_output->{ extra_for_stub }{ name }; 3219 } 3220 3221 if ( $child_output->{crud_output} ) { 3222 my $crud_name = $self->{__NAME__}; 3223 $crud_name =~ s/_form//; 3224 $crud_name ||= 'crud'; 3225 3226 my $text_descr = $controller_statements->{text_description}[0]; 3227 my $model_alias = $data->{model_alias}; 3228 3229 unless ( defined $model_alias and $model_alias ) { 3230 die "Error: controller $base_name is type CRUD but is missing\n" 3231 . " it's controls table statement.\n"; 3232 } 3233 3234 my $with_perms = $self->{__PARENT__}->walk_postorder( 3235 'with_perms' 3236 )->[0]; 3237 3238 my $crud_helpers = Bigtop::Backend::Control::Gantry::crud_helpers( 3239 { 3240 form_method_name => $self->{__NAME__}, 3241 crud_name => $crud_name, 3242 text_descr => $text_descr || 'missing text descr', 3243 model_alias => $model_alias, 3244 with_perms => $with_perms, 3245 } 3246 ); 3247 3248 $crud_doc_methods = _crud_doc_methods( $crud_helpers ); 3249 3250 my $form_method = 3251 Bigtop::Backend::Control::Gantry::gen_controller_method( 3252 { 3253 method_name => $self->{__NAME__}, 3254 child_output => $child_output->{crud_output}, 3255 } 3256 ); 3257 3258 $output = $crud_helpers; 3259 $gen_output .= $form_method; 3260 3261 $output .= Bigtop::Backend::Control::Gantry::controller_method( 3262 { 3263 method_name => $self->{__NAME__}, 3264 gen_package_name => $gen_package_name, 3265 child_output => { doc_args => '$data' }, 3266 } 3267 ); 3268 3269 $gen_method_name = $self->{__NAME__}; 3270 } 3271 3272 return [ 3273 [ 3274 gen_output => $gen_output, 3275 output => $output, 3276 stub_method_name => $stub_method_name, 3277 gen_method_name => $gen_method_name, 3278 extra_stub_method_name => $extra_stub_method, 3279 soap_params => $child_output->{ soap_params }, 3280 soap_style => ( $child_output->{ soap_params } ) 3281 ? $type 3282 : undef, 3283 crud_doc_methods => $crud_doc_methods, 3284 ] 3285 ]; 3286} 3287 3288sub _crud_doc_methods { 3289 my $crud_output = shift; 3290 3291 my @retval = ( $crud_output =~ /^sub\s+(\S+)/msg ); 3292 3293 return \@retval; 3294} 3295 3296package # method_body 3297 method_body; 3298use strict; use warnings; 3299 3300sub get_table_name_for { 3301 my $self = shift; 3302 my $lookup = shift; 3303 my $name_of = shift; 3304 3305 my $table_name = $self->get_table_name( $lookup ); 3306 3307 unless ( $table_name ) { 3308 die "Error: I can't generate main_listing in $name_of->{method} " 3309 . "of controller $name_of->{controller}.\n" 3310 . " The controller did not have a 'controls_table' statement.\n"; 3311 } 3312 3313 $name_of->{table} = $table_name; 3314} 3315 3316sub get_fields_from { 3317 my $self = shift; 3318 my $lookup = shift; 3319 my $name_of = shift; 3320 3321 my $fields = $lookup->{tables}{ $name_of->{table} }{fields}; 3322 3323 unless ( $fields ) { 3324 die "Error: I can't generate main_listing for $name_of->{method} " 3325 . "of controller $name_of->{controller}.\n" 3326 . " I can't seem to find the fields in the table for " 3327 . "this controller.\n" 3328 . " I was looking for them in the table named '$name_of->{table}'.\n" 3329 . " Maybe that name is misspelled.\n"; 3330 } 3331 3332 return $fields; 3333} 3334 3335sub get_field_for { 3336 my $col = shift; 3337 my $fields = shift; 3338 my $name_of = shift; 3339 3340 my $field = $fields->{$col}; 3341 3342 # make sure there really is a field 3343 unless ( $field ) { 3344 die "Error: I couldn't find a field called '$col' in " 3345 . "$name_of->{table}\'s field list.\n" 3346 . " Perhaps you misspelled '$col' in the definition of\n" 3347 . " method $name_of->{method} for controller " 3348 . "$name_of->{controller}.\n"; 3349 } 3350 3351 return $field; 3352} 3353 3354sub output_stub { 3355 my $self = shift; 3356 my $child_output = shift; 3357 my $data = shift; 3358 3359 my $choices = { @{ $child_output } }; 3360 3361 # set up args 3362 my ( $arg_capture, @doc_args ) 3363 = _build_arg_capture( @{ $choices->{extra_args} } ); 3364 3365 return [ 3366 stub_output => { 3367 body => $arg_capture, 3368 doc_args => \@doc_args, 3369 } 3370 ]; 3371} 3372 3373sub output_base_links { 3374 my $self = shift; 3375 my $child_output = shift; 3376 my $data = shift; 3377 3378 my $choices = { @{ $child_output } }; 3379 3380 # set up args 3381 my ( $arg_capture, @doc_args ) 3382 = _build_arg_capture( @{ $choices->{extra_args} } ); 3383 3384 my $title = $choices->{title}[0] || 'Main Listing'; 3385 my $template = $choices->{html_template}[0] || 'main.tt'; 3386 3387 # set self vars for title/template etc. 3388 my $self_setup = Bigtop::Backend::Control::Gantry::self_setup( 3389 { title => $title, template => $template } 3390 ); 3391 3392 my $view_data = Bigtop::Backend::Control::Gantry::main_links( 3393 { pages => $data->{ pages } } 3394 ); 3395 3396 return [ 3397 gen_output => { 3398 body => "$arg_capture\n$self_setup\n$view_data", 3399 doc_args => \@doc_args, 3400 }, 3401 comment_output => { 3402 doc_args => \@doc_args, 3403 } 3404 ]; 3405} 3406 3407sub output_hashref { 3408 my $self = shift; 3409 my $child_output = shift; 3410 my $data = shift; 3411 3412 my $choices = { @{ $child_output } }; 3413 3414 # set up args 3415 my ( $arg_capture, @doc_args ) 3416 = _build_arg_capture( @{ $choices->{extra_args} } ); 3417 3418 3419 my @literals; 3420 foreach my $literal ( @{ $choices->{literal} } ) { 3421 push( @literals, $literal ); 3422 } 3423 3424 my %authed_methods; 3425 if ( $choices->{authed_methods} ) { 3426 foreach my $pair ( @{ $choices->{authed_methods} } ) { 3427 my ( $key, $value ) = %{ $pair }; 3428 $authed_methods{ $key } = $value; 3429 } 3430 } 3431 3432 my @permissions; 3433 if ( $choices->{permissions} ) { 3434 foreach my $pair ( @{ $choices->{permissions} } ) { 3435 my ( $key, $value ); 3436 3437 if ( ref( $pair ) eq 'HASH' ) { ( $key, $value ) = %{ $pair }; } 3438 else { $key = $pair; } 3439 3440 if ( $key !~ /[crud-]+/ or length( $key ) ne 12 ) { 3441 die "invalid permission bits, $key ( usage: crudcrudcrud )\n" 3442 . "at " . $self->get_controller_name . "\n"; 3443 } 3444 3445 push( @permissions, $key ); 3446 push( @permissions, $value ); 3447 } 3448 } 3449 3450 my $config_hashref = Bigtop::Backend::Control::Gantry::hashref( 3451 { 3452 authed_methods => \%authed_methods, 3453 permissions => \@permissions, 3454 literals => \@literals, 3455 } 3456 ); 3457 3458 return [ 3459 gen_output => { 3460 body => "$arg_capture\n$config_hashref", 3461 doc_args => \@doc_args, 3462 }, 3463 comment_output => { 3464 doc_args => \@doc_args, 3465 }, 3466 ]; 3467} 3468 3469sub output_links { 3470 my $self = shift; 3471 my $child_output = shift; 3472 my $data = shift; 3473 3474 my $choices = { @{ $child_output } }; 3475 3476 # set up args 3477 my ( $arg_capture, @doc_args ) 3478 = _build_arg_capture( @{ $choices->{extra_args} } ); 3479 3480 my @abs_pages; 3481 foreach my $page ( @{ $data->{ pages } } ) { 3482 my $abs_page; 3483 3484 if ( $page->{ link } =~ m{^/} ) { 3485 $abs_page = { 3486 link => qq{'$page->{ link }'}, 3487 }, 3488 } 3489 else { 3490 $abs_page = { 3491 link => qq{\$self->app_rootp() . '/$page->{ link }'}, 3492 }; 3493 } 3494 $abs_page->{ label } = $page->{ label }; 3495 push @abs_pages, $abs_page; 3496 } 3497 3498 my $body = Bigtop::Backend::Control::Gantry::site_links( 3499 { pages => \@abs_pages } 3500 ); 3501 3502 return [ 3503 gen_output => { 3504 body => "$arg_capture\n$body", 3505# body => "$arg_capture\n$self_setup\n$view_data", 3506 doc_args => \@doc_args, 3507 }, 3508 comment_output => { 3509 doc_args => \@doc_args, 3510 } 3511 ]; 3512} 3513 3514sub output_main_listing { 3515 my $self = shift; 3516 my $child_output = shift; 3517 my $data = shift; 3518 3519 my $choices = { @{ $child_output } }; 3520 my @optional_args; 3521 3522 # see if we are paging 3523 my $rows = $choices->{ rows }[0] || undef; 3524 if ( $choices->{ paged_conf }[0] ) { 3525 $rows = '$self->' . $choices->{ paged_conf }[0]; 3526 } 3527 3528 # see if we are limiting output rows by foreign key 3529 my $limit_by = $choices->{ limit_by }[0] || undef; 3530 if ( defined $limit_by ) { 3531 push @{ $choices->{ extra_args} }, '$' . $limit_by; 3532 } 3533 3534 # set up args 3535 my ( $arg_capture, @doc_args ) 3536 = _build_arg_capture( @{ $choices->{extra_args} } ); 3537 3538 # provide defaults 3539 my $title = $choices->{title}[0] || 'Main Listing'; 3540 my $template = $choices->{html_template}[0] || 'results.tt'; 3541 3542 # set self vars for title/template etc. 3543 my $self_setup = Bigtop::Backend::Control::Gantry::self_setup( 3544 { title => $title, template => $template, with_real_loc => 1 } 3545 ); 3546 3547 # set up headings 3548 my @col_labels; 3549 my @cols; 3550 my @pseudo_cols; 3551 my @foreigners; 3552 my %name_of; 3553 3554 $name_of{method} = $self->get_method_name(); 3555 $name_of{controller} = $self->get_controller_name(); 3556 3557 $self->get_table_name_for( $data->{lookup}, \%name_of ); 3558 3559 my $fields = $self->get_fields_from( $data->{lookup}, \%name_of ); 3560 3561 foreach my $col ( @{ $choices->{cols} } ) { 3562 my $field = get_field_for( $col, $fields, \%name_of ); 3563 3564 # Push column onto pseudo_cols array if it's a requested pseudo column. 3565 if ($fields->{$col}{pseudo_value}) { 3566 push @pseudo_cols, { alias => $col, field => $fields->{$col}{pseudo_value}{args}[0] } 3567 } 3568 3569 # get the field's label 3570 my $label; 3571 if ( defined $choices->{col_labels} and @{ $choices->{col_labels} } ) { 3572 my $element = shift @{ $choices->{col_labels} }; 3573 if ( ref( $element ) =~ /HASH/ ) { 3574 my ( $text, $link ) = %{ $element }; 3575 push @col_labels, { href => { text => $text, link => $link } }; 3576 } 3577 else { 3578 push @col_labels, { simple => $element }; 3579 } 3580 } 3581 else { 3582 $label = $fields->{$col}{label}{args}[0]; 3583 unless ( $label ) { 3584 warn "Warning: I couldn't find the label for " 3585 . "'$col' in $name_of{table}\'s fields.\n" 3586 . " Using '$col' as the label in method $name_of{method}" 3587 . " of\n" 3588 . " controller $name_of{controller}.\n"; 3589 3590 $label = $col; 3591 } 3592 push @col_labels, { simple => $label }; 3593 } 3594 3595 # see if it's foreigner or has a special display method 3596 if ( defined $fields->{$col}{refers_to} ) { 3597 push @cols, "\$$col"; 3598 push @foreigners, $col; 3599 } 3600 elsif ( defined $fields->{ $col }{ html_form_options } ) { 3601 push @cols, "\$row->${col}_display()"; 3602 } 3603 else { 3604 push @cols, "\$row->$col"; 3605 } 3606 } 3607 3608 # Populate pseudo_cols array for any pseudo columns that weren't requested 3609 # in $choices->{cols}. 3610 foreach my $pseudo_col ( @{ $choices->{pseudo_cols} } ) { 3611 push @pseudo_cols, { alias => $pseudo_col, field => $fields->{$pseudo_col}{pseudo_value}{args}[0] } 3612 } 3613 3614 # put options in the heading bar 3615 my $header_options = []; 3616 if ( $choices->{header_options} ) { 3617 my $url_suffix = ( defined $limit_by ) ? '$header_option_suffix' : ''; 3618 3619 my $perms; 3620 if ( $choices->{ header_option_perms } ) { 3621 $perms = $choices->{ header_option_perms }->one_hash(); 3622 } 3623 3624 $header_options = _build_options( 3625 { 3626 options => $choices->{header_options}, 3627 url_suffix => $url_suffix, 3628 perms => $perms, 3629 } 3630 ); 3631 } 3632 3633 my $heading = Bigtop::Backend::Control::Gantry::main_heading( 3634 { 3635 headings => \@col_labels, 3636 header_options => $header_options, 3637 limit_by => $limit_by, 3638 } 3639 ); 3640 3641 my $order_by; 3642 if ( $choices->{order_by} ) { 3643 $order_by = $choices->{order_by}[0]; 3644 } 3645 3646 # generate database retrieval 3647 my $row_options = []; 3648 if ( $choices->{row_options} ) { 3649 my $perms; 3650 if ( $choices->{ row_option_perms } ) { 3651 $perms = $choices->{ row_option_perms }->one_hash(); 3652 } 3653 $row_options = _build_options( 3654 { 3655 options => $choices->{ row_options }, 3656 row_options => 1, 3657 perms => $perms, 3658 } 3659 ); 3660 #, '/$id' ); 3661 } 3662 3663 my @where_terms; 3664 if ( $choices->{ where_terms } ) { 3665 foreach my $where_term ( @{ $choices->{ where_terms } } ) { 3666 my ( $col_name, $value ) = %{ $where_term }; 3667 push @where_terms, { 3668 col_name => $col_name, 3669 value => $value, 3670 }; 3671 } 3672 } 3673 3674 my $main_table = Bigtop::Backend::Control::Gantry::main_table( 3675 { 3676 model => $data->{model_alias}, 3677 rows => $rows, 3678 data_cols => \@cols, 3679 pseudo_cols => \@pseudo_cols, 3680 row_options => $row_options, 3681 dbix => $self->is_dbix_class( $data ), 3682 limit_by => $limit_by, 3683 foreigners => \@foreigners, 3684 livesearch => $choices->{livesearch}[0], 3685 order_by => $order_by, 3686 where_terms => \@where_terms, 3687 } 3688 ); 3689 3690 # return the result 3691 # We must call the templates separately, Inline::TT does not support 3692 # including one block inside another. (Since each block is logically 3693 # a file and you can never call a block in another file with TT. 3694 # In reality the reason is a bit more subtle. To call a block, with 3695 # Inline::TT, you need to call it as a function in the Bigtop::* class. 3696 # But inside the templates, you cannot call a Perl function without 3697 # enabling Perl code, which we don't want to do.) 3698 return [ 3699 gen_output => { 3700 body => "$arg_capture\n$self_setup\n$heading\n$main_table", 3701 doc_args => \@doc_args, 3702 }, 3703 comment_output => { 3704 doc_args => \@doc_args, 3705 } 3706 ]; 3707} # END output_main_listing 3708 3709sub is_dbix_class { 3710 my $self = shift; 3711 my $data = shift; 3712 my $config_block = $data->{ tree }->get_config()->{ Control }; 3713 3714 return $config_block->{ dbix }; 3715} 3716 3717sub output_SOAP { 3718 my $self = shift; 3719 my $child_output = shift; 3720 my $data = shift; 3721 my $choices = { @{ $child_output } }; 3722 3723 my $extra_comment_methods; 3724 if ( not defined $data->{ WSDL_COMMENTS } ) { 3725 $extra_comment_methods = [ qw( namespace get_soap_ops ) ], 3726 3727 $data->{ WSDL_COMMENTS } = 'done'; 3728 } 3729 3730 my $handler_method = $self->get_method_name(); 3731 ( my $internal_method = $handler_method ) =~ s/^do_//; 3732 3733 my $extra_sub = Bigtop::Backend::Control::Gantry::SOAP_stub_method( 3734 { 3735 handler_method => $handler_method, 3736 internal_method => $internal_method, 3737 } 3738 ); 3739 3740 my $soap_params = _extract_soap_params( $choices, $internal_method ); 3741 3742 return [ 3743 extra_for_stub => { 3744 name => $internal_method, 3745 full_sub => $extra_sub, 3746 }, 3747 extra_comment_methods => $extra_comment_methods, 3748 soap_params => $soap_params, 3749 soap_style => 'RPC', 3750 ]; 3751} 3752 3753sub output_SOAPDoc { 3754 my $self = shift; 3755 my $child_output = shift; 3756 my $data = shift; 3757 my $choices = { @{ $child_output } }; 3758 3759 my $extra_comment_methods; 3760 if ( not defined $data->{ WSDL_COMMENTS } ) { 3761 $extra_comment_methods = [ qw( namespace get_soap_ops ) ], 3762 3763 $data->{ WSDL_COMMENTS } = 'done'; 3764 } 3765 3766 # set up args 3767 my ( $arg_capture, @doc_args ) 3768 = _build_arg_capture( @{ $choices->{extra_args} } ); 3769 3770 my $handler_method = $self->get_method_name(); 3771 ( my $internal_method = $handler_method ) =~ s/^do_//; 3772 3773 my $soap_params = _extract_soap_params( $choices, $internal_method ); 3774 3775 my $body_advice = Bigtop::Backend::Control::Gantry::soap_doc_advice( 3776 { 3777 arg_capture => $arg_capture, 3778 soap_params => $soap_params, 3779 handler_method => $handler_method, 3780 } 3781 ); 3782 3783 return [ 3784 soap_style => 'SOAPDoc', 3785 extra_for_stub => { 3786 name => $handler_method, 3787 full_sub => $body_advice, 3788 }, 3789 soap_params => $soap_params, 3790 extra_comment_methods => $extra_comment_methods, 3791 ]; 3792} 3793 3794sub _extract_soap_params { 3795 my $choices = shift; 3796 my $internal_method = shift; 3797 3798 my %soap_params; 3799 $soap_params{ name } = $internal_method; 3800 3801 foreach my $expected ( @{ $choices->{ expects } } ) { 3802 if ( ref( $expected ) eq 'HASH' ) { 3803 my ( $name, $type ) = %{ $expected }; 3804 push @{ $soap_params{ expects } }, 3805 { name => $name, type => $type }; 3806 } 3807 else { 3808 push @{ $soap_params{ expects } }, 3809 { name => $expected, type => 'xsd:string' }; 3810 } 3811 } 3812 3813 foreach my $returned ( @{ $choices->{ returns } } ) { 3814 if ( ref( $returned ) eq 'HASH' ) { 3815 my ( $name, $type ) = %{ $returned }; 3816 push @{ $soap_params{ returns } }, 3817 { name => $name, type => $type }; 3818 } 3819 else { 3820 push @{ $soap_params{ returns } }, 3821 { name => $returned, type => 'xsd:string' }; 3822 } 3823 } 3824 3825 return \%soap_params; 3826} 3827 3828# Given 3829# [ Label => url, Label2 => url2, Label_no_url; ] 3830# Returns 3831# [ 3832# { text => 'Label', link => 'url' }, 3833# { text => 'Label2', link => 'url2' }, 3834# { text => 'Plain_Label', link => '$$self{location}/plain_label' }, 3835# ] 3836my %crud_type_for = ( 3837 add => 'create', 3838 create => 'create', 3839 view => 'retrieve', 3840 edit => 'update', 3841 udpate => 'update', 3842 delete => 'delete', 3843); 3844sub _build_options { 3845 my $opts = shift; 3846 my $bigtop_args = $opts->{ options }; 3847 my $url_suffix = $opts->{ url_suffix }; 3848 my $row_options = $opts->{ row_options } || 0; 3849 my $perms = $opts->{ perms } || {}; 3850 3851 my @options; 3852 foreach my $option ( @{ $bigtop_args } ) { 3853 my $label; 3854 my $location; 3855 my $crud_type; 3856 my $action; 3857 3858 if ( ref( $option ) =~ /HASH/ ) { 3859 ( $label, $location ) = %{ $option }; 3860 3861 if ( $row_options ) { # remove /$id if present 3862 $location =~ s{ / \$ id (.)? $ }{$1}x; 3863 } 3864 $action = _label_to_action( $label ); 3865 } 3866 else { 3867 $label = $option; 3868 $action = _label_to_action( $label ); 3869 3870 if ( not $row_options ) { 3871 $location = '$real_location . "' . 3872 $action . $url_suffix . '"'; 3873 } 3874 3875 } 3876 $crud_type = $perms->{ $label } || $crud_type_for{ $action }; 3877 3878 if ( $row_options ) { 3879 $crud_type ||= 'retrieve'; 3880 } 3881 else { 3882 $crud_type ||= 'create'; 3883 } 3884 3885 push @options, { 3886 text => $label, 3887 location => $location, 3888 type => $crud_type, 3889 }; 3890 } 3891 3892 return \@options; 3893} 3894 3895sub _label_to_action { 3896 my $label = shift; 3897 my $action = lc $label; 3898 3899 $action =~ s/ /_/g; 3900 3901 return $action; 3902} 3903 3904sub _build_arg_capture { 3905 my @extras = @_; 3906 3907 my @args = ( '$self', @extras ); 3908 my $arg_capture = 3909 Bigtop::Backend::Control::Gantry::arg_capture_st_nick_style( 3910 { args => \@args } 3911 ); 3912 3913 return ( $arg_capture, @extras ); 3914} 3915 3916sub _crud_form_outputer { 3917 my $self = shift; 3918 my $child_output = shift; 3919 my $data = shift; 3920 shift; # parent. not needed. 3921 my $auto_crud = shift || 0; 3922 3923 # set up args 3924 my $choices = { @{ $child_output } }; 3925 3926 my $default_arg = ( $auto_crud ) ? '$row' : '$data'; 3927 3928 my ( $arg_capture, @doc_args ) 3929 = _build_arg_capture( $default_arg, @{ $choices->{extra_args} } ); 3930 3931 # get the fields 3932 my %name_of; 3933 $name_of{method} = $self->get_method_name(); 3934 $name_of{controller} = $self->get_controller_name(); 3935 3936 if ( $name_of{method} eq '_form' ) { 3937 if ( $auto_crud ) { 3938 warn "form methods should be called form (not _form)\n"; 3939 } 3940 else { 3941 warn "form methods should have a name like my_form, " 3942 . "not just _form\n"; 3943 } 3944 } 3945 3946 $self->get_table_name_for( $data->{lookup}, \%name_of ); 3947 3948 my $fields = $self->get_fields_from( $data->{lookup}, \%name_of ); 3949 3950 unless ( defined $choices->{fields} 3951 or 3952 defined $choices->{all_fields_but} ) 3953 { 3954 die "Error: I can't generate AutoCRUD_form for $name_of{method} " 3955 . "of controller $name_of{controller}.\n" 3956 . " No fields (or all_fields_but) were given.\n"; 3957 } 3958 3959 my $requested_fields; 3960 3961 if ( defined $choices->{all_fields_but} ) { 3962 $requested_fields = _find_all_fields_but( 3963 $choices->{all_fields_but}, 3964 $data, 3965 $name_of{table} 3966 ); 3967 } 3968 else { 3969 $requested_fields = $choices->{fields}; 3970 } 3971 3972 my @field_lookups; 3973 my @refers_to; 3974 foreach my $field_name ( @{ $requested_fields } ) { 3975 my $field = get_field_for( $field_name, $fields, \%name_of ); 3976 3977 my %clean_field; 3978 3979 $clean_field{name} = $field_name; 3980 3981 FIELD_STATEMENT: 3982 foreach my $key ( keys %{ $field } ) { 3983 next FIELD_STATEMENT if ( $key eq '__IDENT__' ); 3984 3985 my $clean_key = $key; 3986 $clean_key =~ s/html_form_//; 3987 3988 my $clean_value = $field->{$key}{args}[0]; 3989 3990 # translate foreign key into select list 3991 if ( $clean_key eq 'refers_to' ) { 3992 $clean_key = 'options_string'; 3993 3994 if ( ref( $clean_value ) eq 'HASH' ) { 3995 ( $clean_value ) = %{ $clean_value }; 3996 } 3997 $clean_value =~ s/\./_/; # might have schema prefix 3998 push( @refers_to, $clean_value ); 3999 $clean_value = '$selections->{' . $clean_value . '}'; 4000 } 4001 # pull out all pairs 4002 elsif ( $clean_key eq 'options' ) { 4003 my @option_pairs; 4004 foreach my $pair ( @{ $field->{$key}{args} } ) { 4005 push @option_pairs, $pair; 4006 } 4007 $clean_value = \@option_pairs; 4008 } 4009 else { 4010 $clean_value = $field->{$key}{args}[0]; 4011 } 4012 4013 $clean_field{ $clean_key } = $clean_value; 4014 } 4015 4016 push @field_lookups, \%clean_field; 4017 } 4018 4019 my %extra_keys; 4020 if ( $choices->{extra_keys} ) { 4021 foreach my $pair ( @{ $choices->{extra_keys} } ) { 4022 my ( $key, $value ) = %{ $pair }; 4023 $extra_keys{ $key } = $value; 4024 } 4025 } 4026 4027 # build body 4028 my $form_body = Bigtop::Backend::Control::Gantry::form_body( 4029 { 4030 model => $data->{model_alias}, 4031 form_name => $choices->{form_name}[0], 4032 fields => \@field_lookups, 4033 refers_to => \@refers_to, 4034 extra_keys => \%extra_keys, 4035 raw_row => $auto_crud, 4036 dbix => $self->is_dbix_class( $data ), 4037 } 4038 ); 4039 4040 my $output_type = ( $auto_crud ) ? 'gen_output' : 'crud_output'; 4041 4042 return [ 4043 $output_type => { 4044 body => "$arg_capture\n$form_body", 4045 doc_args => \@doc_args, 4046 }, 4047 comment_output => { 4048 doc_args => \@doc_args, 4049 } 4050 ]; 4051} 4052 4053sub output_AutoCRUD_form { 4054 return _crud_form_outputer( @_, 1 ); 4055} 4056 4057sub output_CRUD_form { 4058 my ( $self, undef, $data ) = @_; 4059 4060 return _crud_form_outputer( @_, 0 ); 4061} 4062 4063sub _find_all_fields_but { 4064 my $excluded_fields = shift; 4065 my $data = shift; 4066 my $table_name = shift; 4067 4068 my $bigtop_tree = $data->{tree}; 4069 4070 # ask the corresponding table for its fields 4071 my $fields = $bigtop_tree->walk_postorder( 4072 'output_field_names', { table_of_interest => $table_name } 4073 ); 4074 4075 my @retval; 4076 4077 # now build the return list 4078 my %exclude_this; 4079 @exclude_this{ @{ $excluded_fields } } = @{ $excluded_fields }; 4080 4081 foreach my $field ( @{ $fields } ) { 4082 push @retval, $field unless $exclude_this{ $field }; 4083 } 4084 4085 return \@retval; 4086} 4087 4088package # method_statement 4089 method_statement; 4090use strict; use warnings; 4091 4092sub with_perms { 4093 my $self = shift; 4094 4095 return unless $self->{__KEYWORD__} eq 'permissions'; 4096 4097 return [ $self->{__ARGS__} ]; 4098} 4099 4100sub walker_output { 4101 my $self = shift; 4102 4103 return [ $self->{__KEYWORD__} => $self->{__ARGS__} ]; 4104} 4105 4106sub output_hashref { goto &walker_output; } 4107 4108sub output_stub { goto &walker_output; } 4109 4110sub output_main_listing { goto &walker_output; } 4111 4112sub output_AutoCRUD_form { goto &walker_output; } 4113 4114sub output_CRUD_form { goto &walker_output; } 4115 4116sub output_base_links { goto &walker_output; } 4117 4118sub output_links { goto &walker_output; } 4119 4120sub output_SOAP { goto &walker_output; } 4121 4122sub output_SOAPDoc { goto &walker_output; } 4123 41241; 4125