The perl code listed below is taken from COSAS which is a custom web-based inventory control/asset management application that was written and maintained by Tim Turnquist for Common Hope.

This code demonstrates:

Style Strict adherence to perl style standards and self-imposed guidelines to increase readability -- which improves maintainability -- as demonstrated by: Concise in-line documentation Use of STRICT pragma and all variables declared Beginning of functions easy to find with comment headers No line over 80 characters long Uses easy to understand variable naming convention with an underscore is used for internal variables. Function Use of Object Orientation Interaction with other objects and modules Interaction with the system and files stored on disk Use of code wrappers for multi-use code or objects Use of complex data structures such as hashes Use of references Use of DBI and database interaction Use of CGI and Common Gateway Interface interaction Complete separation of Business logic from Interface logic (and wrappers for all database functions) to further encapsulate the application layers. Using this system it is easy to change one part of the system -- for example one could change the entire user interface by only changing the user interface package(s) or changing the database by changing the DB wrapper(s).

More code samples available upon request

   1    package master_class;
   2    
   3    use strict;
   4    use Class::ISA;
   5    use CGI qw/:standard/;
   6    use DBI;
   7    
   8    package master_business_class;
   9    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
  10    ################################ PACKAGE #######################################
  11    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
  12    #       BBBBB  U   U  SSSS IIIII NN    N EEEEE  SSSS  SSSS        CCCC L       #
  13    #       B    B U   U SS      I   N N   N E     SS    SS          C     L       #
  14    #       BBBBB  U   U  SSS    I   N  N  N EEE    SSS   SSS        C     L       #
  15    #       B    B U  UU    SS   I   N   N N E        SS    SS       C     L      A#
  16    #       BBBBB   UU U SSSS  IIIII N    NN EEEEE SSSS  SSSS  _____  CCCC LLLLL A #
  17    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
  18    ################################################################################
  19    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
  20    
  21    require db_DB_funcs;
  22    require sl_general;
  23    require ui_CGI_funcs;
  24    
  25    my $_sep1 = "~~";
  26    my $_sep2 = "||";
  27    
  28    sub new
  29    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
  30    #                         NN    N EEEEEEE W           W                        #
  31    #                         N N   N E        W         W                         #
  32    #                         N  N  N EEEE      W   W   W                          #
  33    #                         N   N N E          W W W W                           #
  34    #                         N    NN EEEEEEE     W   W                            #
  35    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
  36    # Constructor
  37    # USAGE
  38    #    my $new_oject = o_things->new(); #gets a new object
  39    #    my $saved_object = o_things->new( ID => "1234567890" );
  40    #              loads data about an object from the database
  41    {
  42      my $self = {};
  43      my( $_class, %_args ) = @_;
  44      bless $self, $_class;
  45      #                                                    Initialize the new object
  46      $self->_init( %_args );
  47      return $self;
  48    };
  49    
  50    sub _init
  51    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
  52    #                         IIIII NN    N IIIII TTTTTTT                          #
  53    #                           I   N N   N   I      T                             #
  54    #                           I   N  N  N   I      T                             #
  55    #                           I   N   N N   I      T                             #
  56    #                  ______ IIIII N    NN IIIII    T                             #
  57    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
  58    # Initialization
  59    {
  60      my( $self, %_args ) = @_;
  61    
  62      # -  -  -  - Get the names of the columns from the database VIEW -  -  -  -  -
  63      # change the 'o_' of the class name to a 'v_' for the database VIEW of the
  64      # same name
  65      my $_view_name = ref( $self );
  66      $_view_name =~ s/o_/v_/;
  67    
  68      my $_desc_pointer = db_DB_funcs::simple_DESC
  69          (  table    => $_view_name
  70            #, debug    => "HTML" # Either 'HTML' or 'PERL'
  71          ) ;
  72    
  73      # Initialize all properties of the temp hash to ""
  74      my %_init_vals;
  75      foreach my $_key ( @$_desc_pointer ){ $_init_vals{ $_key } = "" } ;
  76    
  77      #   Create a WHERE clause from the passed conditions by first setting it to be
  78      #               TRUE ( 1=1 ) so that all other conditions can start with 'AND'
  79      #                 or send FALSE (10=1) and return nothing if nothing is passed
  80      my $_where = ( keys %_args gt 0 ? "1 = 1" : "10 = 1" );
  81      foreach my $_key ( keys %_args )
  82      {
  83        $_where .= " AND $_key = '$_args{ $_key }'"
  84      }
  85    
  86      #                                initialize the object with values from the DB
  87      my $_select_pointer = db_DB_funcs::simple_SELECT
  88            (  table    => $_view_name
  89             , columns  => "*"
  90             , where    => "$_where"
  91       #      , debug    => "HTML" # Either 'HTML' or 'PERL'
  92            ) ;
  93    
  94      my @row = $_select_pointer -> fetchrow_array ;
  95    
  96      for( my $_col = 0; $_col < @row ; $_col++ )
  97      {
  98        $_init_vals { $_select_pointer -> { NAME } -> [ $_col ] }
  99                    = $row[ $_col ]
 100      }
 101    
 102      #                          Initialize each key with a VALUE from the temp hash
 103      foreach my $_key ( @$_desc_pointer )
 104      {
 105        $self->{ "_" . $_key } = ucfirst( $_init_vals { $_key } );
 106      };
 107    };
 108    
 109    sub get
 110    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 111    #                          GGGGGG EEEEEEE TTTTTTT                              #
 112    #                         G       E          T                                 #
 113    #                         G   GGG EEEE       T                                 #
 114    #                         G     G E          T                                 #
 115    #                          GGGGG  EEEEEEE    T                                 #
 116    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 117    #        Gets values from the object to pass to the outside world.  At least one
 118    #         paramater needs to be passed and that is the atribute(s) of the object
 119    #         that are being requested.  (This is in place of get_ID, get_name, etc)
 120    
 121    # Takes:
 122    #     A list of object attributes to retrieve the values for
 123    
 124    # Returns:
 125    #     A single string of all of the values requested seperated by $_sep ( ~~ )
 126    
 127    #  USAGE:
 128    #  print "ID = " . $obj -> get( "ID" ) . "<BR>";
 129    #  my( $ID, $name ) = split( $_sep1, $obj -> get( "ID", "name" ) );
 130    {
 131      my( $self, @_list ) = @_;
 132      my $_retval;
 133      my @_temp;
 134      my @_keys;
 135    
 136      #                     Make sure that an entry in the list is not a list itself
 137      foreach my $_i ( @_list )
 138      {
 139        my $_temp = $_i;
 140        $_temp =~ s/,\s*/,/g;                           # Clean out spaces by commas
 141        @_temp = split( $_sep1, $_temp );
 142        push @_keys, @_temp;
 143      }
 144    
 145      @_temp = ();
 146      for( my $_i = 0; $_i < @_keys; $_i++ )
 147      {
 148        $_keys[ $_i ] =~ s/"//g;                       #Get rid of quotes in the key
 149        push @_temp, $self->{ "_" . $_keys[ $_i ] };
 150      }
 151      $_retval = join( $_sep1, @_temp );
 152      return $_retval;
 153    };
 154    
 155    sub set
 156    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 157    #                          SSSSSS EEEEEEE TTTTTTT                              #
 158    #                         SS      E          T                                 #
 159    #                          SSSSS  EEEE       T                                 #
 160    #                              SS E          T                                 #
 161    #                         SSSSSS  EEEEEEE    T                                 #
 162    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 163    #               Sets values in the object as passed from the outside world.  Two
 164    #            paramaters needs to be passed; the atribute of the object to change
 165    #                and the new value.  (This is in place of set_ID, set_name, etc)
 166    
 167    # Takes:
 168    #     One object attribute
 169    #     One value to change the attribute to
 170    
 171    # Returns:
 172    #     "$_list[ 0 ] Successfully Updated" if successful
 173    #     Otherwise returns an error message
 174    
 175    #  USAGE:
 176    #  if(  $obj -> set( "name", "bob" ) =~ /Successf/ ) { print "Hey Cool"};
 177    #  $obj -> set( "name", "Chicken Head" );
 178    #  $obj -> set( name=>"Chicken Head" );                       # is most readable
 179    {
 180      my( $self, @_list ) = @_;
 181      my $_ret_val = "Unknown Failure";                      # Assume random failure
 182    
 183      my $_not_settable ;#= " _ID ";   #If any attributes are 'read only' list here.
 184    
 185      #                                                        Clean input of quotes
 186      $_list[ 0 ]     =~ s/^["\s](.*)[\s"]$/$1/;
 187      my $_want       = "_" . $_list[ 0 ];
 188      my $_value      = $_list[ 1 ];
 189      $_value         =~ s/"//g ;
 190    
 191      #                    Make sure the SET attribute is on a memeber of the object
 192      my $_is_attribute = 0;  #                       Assume FALSE until proven TRUE
 193    
 194      # If    the key passed is a member of the object then '$is_attribute' is TRUE
 195      $_is_attribute = 1 if( exists( $self->{ $_want } )
 196                            or exists( $self->{ $_list[ 0 ] } ) );
 197    
 198      # If the passed key is not in the not settalbe list
 199      if( $_not_settable !~ /$_want/ )
 200      {
 201        # Then key is a regular key
 202        $self->{ $_want } = ucfirst( $_value );
 203        $_ret_val = "$_list[ 0 ] Successfully Updated";
 204      }
 205      else
 206      {
 207        $_ret_val = ( $_is_attribute
 208                   ? "Can Not Update $_list[ 0 ] on " . ref( $self )
 209                   : "$_list[ 0 ] is not a part of " . ref( $self ) );
 210      }
 211      return $_ret_val
 212    };
 213    
 214    sub bulk_set
 215    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 216    #           BBBBB  U     U  L     K   K        SSSSS EEEEEE TTTTTTT            #
 217    #           B    B U     U  L     K  K        S      E         T               #
 218    #           BBBBB  U     U  L     KKK          SSSS  EEEEE     T               #
 219    #           B    B U    UU  L     K  K             S E         T               #
 220    #           BBBBB   UUUU U  LLLLL K   K _____ SSSSS  EEEEEE    T               #
 221    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 222    #                             This routine cahnges an object based on user input
 223    
 224    # Takes:
 225    #     param() list that starts with a 'input_' which denotes that it is data
 226    #             that is input by the user
 227    
 228    # Returns:
 229    #     Nothing
 230    
 231    #  USAGE:
 232    #  $obj->bulk_set( %_param_list );
 233    
 234    {
 235      my( $self, %_args ) = @_;
 236    #  foreach my $b( sort keys %_args ){print "$b=>$_args{$b}<BR>"};
 237    
 238      foreach my $_key ( sort keys %$self )
 239      {
 240        my $_val = $self->{ $_key };
 241        my $_new_key = $_key;
 242        $_new_key =~ s/^_//;
 243        if( defined( $_args{ 'input' . $_key } ) )
 244        {
 245          $_val           =~ s/^\s*(.*)\s*$/$1/;     # Get rid of leading or closing
 246          $_args{ 'input' . $_key } =~ s/^\s*(.*)\s*$/$1/;     #              spaces
 247    
 248          # For Debugging:
 249          #print "<BR>-Changing key $_new_key from '" . $self->get( $_new_key )
 250          #     . "' to '$_args{ 'input' . $_key }'";
 251    
 252          $self->set( $_new_key => $_args{ 'input' . $_key } );
 253        }
 254      }
 255    
 256    };
 257    
 258    sub _save
 259    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 260    #                      SSSSSS     A     V       V EEEEEEE                      #
 261    #                     SS         A A     V     V  E                            #
 262    #                      SSSSS    AAAAA     V   V   EEEEE                        #
 263    #                          SS  A     A     V V    E                            #
 264    #                     SSSSSS  A       A     V     EEEEEEE                      #
 265    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 266    # Saves the values in the object to the database.  This is an inernal method
 267    #  since it needs to be called on various tables in the proper order.  Thus,
 268    #  use the STORE method to call this one properly.
 269    
 270    # Takes:
 271    #     Only requires the object being saved
 272    
 273    # Returns:
 274    #     ON INSERT the ID if successful
 275    #     ON UPDATE the number of rows updated if successful
 276    #     NULL on failure
 277    
 278    #  USAGE:
 279    #  if(  $obj -> save( ) =~ /^\d*/ ) { print "Hey Cool"};
 280    #  $obj -> save( );
 281    
 282    {
 283      my( $self ) = @_;
 284      my $_ret_val = "Unknown Failure";
 285      my $_table_name = ref( $self );
 286      $_table_name =~ s/o_//;
 287    
 288      # Since the "change_request" object uses the Request table, change to that
 289      $_table_name = "requests" if ref( $self ) =~ /change_request/;
 290    
 291      #                                                             Get column names
 292      my $_col_names_ptr = db_DB_funcs::simple_DESC
 293            (  table    => "$_table_name"
 294      #       , debug    => "HTML" # Either 'HTML' or 'PERL'
 295            ) ;
 296      my $_col_names = join( $_sep1, @$_col_names_ptr ); #   Seperate with '~~'
 297      my $_new_vals = $self->get( $_col_names );
 298    
 299      my ( %_vals, %_dups );
 300      my @_cols = split( $_sep1, $_col_names );
 301      $_new_vals =~ s/,\s*/,/g;                    #get rid of leading spaces if any
 302      my @_vals = split( $_sep1, $_new_vals );
 303    
 304      for( my $_i = 0; $_i < @_cols; $_i++)
 305      {
 306        $_vals{ $_cols[ $_i ] } = qq{"$_vals[ $_i ]"};
 307        $_dups{ $_cols[ $_i ] } = qq{"$_vals[ $_i ]" } unless $_cols[ $_i ] eq "ID";
 308      }
 309    
 310      $_ret_val = db_DB_funcs::simple_INSERT2
 311          (  table       => "$_table_name"
 312           , new_vals    => \%_vals
 313           , on_dup      => \%_dups
 314      #     , debug       =>  "HTML"     # Either 'HTML' or 'PERL'
 315          ) ;
 316      $self->set( ID => "$_ret_val" ) if $self->{ _ID } eq "";   # reset the object
 317    
 318      return $_ret_val;  #                             Return the appropriate value
 319    };
 320    
 321    sub store
 322    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 323    #                    SSSSSS TTTTTTT  OOOOO  RRRRR  EEEEEEE                     #
 324    #                   SS         T    O     O R    R E                           #
 325    #                    SSSSS     T    O     O RRRRR  EEEEE                       #
 326    #                        SS    T    O     O R   R  E                           #
 327    #                   SSSSSS     T     OOOOO  R    R EEEEEEE                     #
 328    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 329    #      This routine saves an object in the database by saving the parent objects
 330    #        first so the Foreign Key restraints are satisfied.  It calls the 'save'
 331    #    method for each of the parent or SUPER objects, then on the object that was
 332    #                                                             originally called.
 333    
 334    # Takes:
 335    #     Only requires the object being saved
 336    
 337    # Returns:
 338    #     ON INSERT the ID if successful
 339    #     ON UPDATE the number of rows updated if successful
 340    #     NULL on failure
 341    
 342    # USAGE:
 343    #  my $ret_val = $obj->store();
 344    {
 345      my( $self ) = @_;
 346      my @_parents = Class::ISA::super_path( ref( $self ) );
 347    
 348      #                     Get rid of the last "parent" if it is the "Master Class"
 349      pop @_parents while $_parents[ @_parents - 1 ] =~ /^master_/;
 350    
 351      while( @_parents gt 0 )
 352      {
 353        #         Get the last "parent" in the ISA array and work on that one first.
 354        #                                  Create a new object from the parent class
 355        my $obj = pop( @_parents )->new( );
 356    
 357        # Iterate                               through all of the object attributes
 358        foreach my $_i ( keys %$obj )
 359        {
 360          my $_attribute = $_i;                  # Get the name of the parent object
 361          $_attribute =~ s/^_(.*)/$1/;        # Strip off the leading underscore (_)
 362          my $_curr_val = $self->{ $_i } ;
 363    
 364          $obj->set( $_attribute, $_curr_val ); # Copy the values of the current
 365                                #                               object to the parent
 366        };
 367    
 368        $obj->_save();                                 # Save this new parent object
 369    
 370        $self->{ _ID } = $obj->{ _ID } if $self->{ _ID } eq "";#Reset the ID if NULL
 371      };
 372      my $_ret_val = $self->_save();                      # Save the original object
 373    
 374      return $_ret_val;  #                             Return the appropriate value
 375    };
 376    
 377    package master_user_interface;
 378    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 379    ################################ PACKAGE #######################################
 380    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 381    #       U    U  SSSSS EEEEE RRRRR        IIIII NN    N TTTTTTT EEEEE  RRRRR    #
 382    #       U    U SS     E     R    R         I   N N   N    T    E      R    R   #
 383    #       U    U  SSSS  EEE   RRRRR          I   N  N  N    T    EEEE   RRRRR    #
 384    #       U   UU     SS E     R   R          I   N   N N    T    E      R   R    #
 385    #        UUU U SSSSS  EEEEE R    R _____ IIIII N    NN    T    EEEEEE R    R   #
 386    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 387    ################################################################################
 388    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 389    
 390    
 391    sub print_me
 392    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 393    #       PPPPP  RRRRR  IIIII NN    N TTTTTTT       MM   MM EEEEEEE              #
 394    #       P    P R    R   I   N N   N    T          M M M M E                    #
 395    #       PPPPP  RRRRR    I   N  N  N    T          M  M  M EEEEE                #
 396    #       P      R   R    I   N   N N    T          M     M E                    #
 397    #       P      R    R IIIII N    NN    T    _____ M     M EEEEEEE              #
 398    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 399    {
 400      my( $self, %_args ) = @_;
 401      print "<TABLE BORDER=0><TR><TD ALIGN='center' CLASS='bigtitle'>";
 402      print "$_args{ message }";
 403      print "<TABLE BORDER=1 WIDTH='100%'>";
 404      foreach my $property ( sort keys %{ $self } )
 405      {
 406        my $_prop = uc( $property );
 407        $_prop =~ s/_/ /g;
 408        print "<TR><TD ALIGN='right' CLASS='title'>$_prop"
 409                            . "<TD CLASS='text'>$self->{ $property }";
 410      };
 411      print "</TABLE>";
 412      print "</TABLE>" unless $_args{ close_table } =~ /no/i;
 413    };
 414    
 415    sub input_me
 416    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 417    #       IIIII NN    N PPPPP  U    U TTTTTTT       MM   MM EEEEEEE              #
 418    #         I   N N   N P    P U    U    T          M M M M E                    #
 419    #         I   N  N  N PPPPP  U    U    T          M  M  M EEEEE                #
 420    #         I   N   N N P      U   UU    T          M     M E                    #
 421    #       IIIII N    NN P       UUU U    T    _____ M     M EEEEEEE              #
 422    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 423    {
 424      my( $self, %_args ) = @_;
 425      print "<TABLE BORDER=0><TR><TD ALIGN='center' CLASS='bigtitle'>";
 426      print "$_args{ message }";
 427      print "<TABLE BORDER=1>";
 428      foreach my $_property ( sort keys %{ $self } )
 429      {
 430        my $_object_name = ref( $self );
 431        $_object_name =~ s/^o_//;
 432        my $_prop = uc( $_property );
 433        $_ = $_prop;
 434        # skip if the property is a name
 435        next if ( /name/i || /nombre/i || /id/i ) && $_object_name =~/trans/ ;
 436        # skip if the property is a name
 437        next if ( /qt/i ) && $_object_name =~/item/ ;
 438        $_prop =~ s/_/ /g;         # Change all underscores (_) to a space ( )
 439        $_prop =~ s/^\s*//;        # Remove Leading spaces
 440        $_prop =~ s/\s*$//;        # Remove Closing spaces
 441    
 442        SWITCH:{
 443          my $_order = "name";
 444          my $_name  = "name"; # "nombre"; #
 445          $_ = $_prop;
 446          if( /status/i || /request/i || /priority/i || /by/i || /thing/ || /type/i
 447             || ( /user/i  and !( /password/i ) ) )
 448          {
 449            # Build POPUP
 450            my $_table;
 451            if( /status/i and !( $_prop =~ /request/i ) )
 452            {
 453              $_table = "thing_status";
 454            }  # end of THING STATUS
 455            elsif( /status/i and /request/i )
 456            {
 457              $_table = "request_status";
 458            }  #end of REQUEST STATUS
 459            elsif( /priority/i )
 460            {
 461              $_table = "request_priorities";
 462              $_order = "ID";
 463            }  #end of PRIORITY
 464            elsif( /user/i || /by/i )
 465            {
 466              $_table = "v_users";
 467              $_name  = "name";
 468            }  #end of USER
 469            elsif( /type/i || /by/i )
 470            {
 471              $_table = "quantity_types";
 472            }  #end of USER
 473            elsif( /thing/i  )
 474            {
 475              $_table = "v_things";
 476            }  #end of thing
 477            elsif( /ID/i )
 478            {
 479              $_table = "$_object_name";
 480            }  #end of ID
 481            else
 482            {
 483              $_table = $_prop;
 484             }; #end of SW_TABLE
 485    
 486            ui_CGI_funcs::popup_from_DB
 487                (  name       => "input_$_property"
 488                 , caption    => "<TR><TD CLASS='title' ALIGN='right'>$_prop"
 489                 , table      => $_table
 490                 , hidden     => "ID"
 491                 , display    => $_name
 492                 , order      => $_order
 493                 , default    => $self->{ $_property }    # Optional
 494                 , seperator  => "<TD>" #| "<TR>" | "<BR>"
 495            #     , debug      =>  "HTML" # "Perl"#
 496                );          last SWITCH;
 497          } #end of Build POPUP
 498    
 499          if( $_prop =~ /note/i )
 500          {
 501            # Build TEXT_AREA
 502            last SWITCH;
 503          }  #end of Build TEXTAREA
 504    
 505          if( $_prop =~ /user password/i )
 506          {
 507            # do nothing
 508            last SWITCH;
 509          }  #end of Build TEXTAREA
 510    
 511          if( $_prop =~ /location/i )
 512          {
 513            # Build WHATEVER
 514            last SWITCH;
 515          }  #end of Build WHATEVER
 516    
 517          if( $_prop =~ /security level/i )
 518          {
 519            # Build WHATEVER
 520            $self->display_security_options();
 521            last SWITCH;
 522          }  #end of Build WHATEVER
 523    
 524          #ELSE use the default TEXTBOX
 525          ui_CGI_funcs::simple_textbox
 526              (  caption    => "<TR><TD ALIGN='right' CLASS='title'>$_prop"
 527               , name       => "input_$_prop"
 528               , default    => $self->{ $_property }   # optional
 529         #      , size       =>    # optional
 530         #      , class      =>    # default class = 'text'
 531               , seperator  =>  "<TD CLASS='text'>" #"<TD>" | "<TR>" | "<BR>"
 532              );
 533        } #end of SWITCH
 534      }  # end of FOREACH property
 535      print "</TABLE><TR><TD ALIGN='center'>
 536             <INPUT TYPE='submit' NAME='Huh?'></TABLE><BR>"
 537    
 538    }   # End of method
 539    
 540    sub load_me
 541    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 542    #          L      OOOO      A     DDDDD        MM   MM EEEEEEE                 #
 543    #          L     O    O    A A    D    D       M M M M E                       #
 544    #          L     O    O   AAAAA   D    D       M  M  M EEEEE                   #
 545    #          L     O    O  A     A  D    D       M     M E                       #
 546    #          LLLLL  OOOO  A       A DDDDD  _____ M     M EEEEEEE                 #
 547    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 548    {
 549      my( $self, %_args ) = @_;
 550      #print "<TABLE BORDER=0><TR><TD ALIGN='center' CLASS='bigtitle'>";
 551      #print "$_args{ message }";
 552      #print "<TABLE BORDER=1>";
 553    
 554      my $thing = o_counts->new( thing => "" . param( "ID" ) .  "" );
 555    
 556      my @things_in_me = split( $_sep2, $thing->what_is_in_me() );
 557      foreach my $thing_in_me ( @things_in_me )
 558      {
 559        $thing_in_me =~ /^(.+)\s*$_sep1\s*(.+)\s*$_sep1\s*(.*)$/;
 560        my( $name, $status, $count ) = ( $1, $2, $3 );
 561        print "$name, $status, $count<BR>";
 562      }
 563      print "<BR><SPAN CLASS='error'>Nothing in me" if @things_in_me == 0;
 564    
 565      print "<TR><TD>";
 566    };
 567    
 568    sub display_quick_links
 569    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 570    # DDDD   IIIII  SSSSS PPPPP  L         A     Y     Y        QQQQQ  U    U IIIII#
 571    # D   D    I   S      P    P L        A A     Y   Y        Q     Q U    U   I  #
 572    # D    D   I    SSSS  PPPPP  L       AAAAA     Y Y         Q     Q U    U   I  #
 573    # D   D    I        S P      L      A     A     Y          Q  QQ Q U   UU   I  #
 574    # DDDD   IIIII SSSSS  P      LLLLL A       A    Y    _____  QQQQQQ  UUU U IIIII#
 575    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 576    {
 577      my( $self, %_args ) = @_;
 578    
 579      # Debug
 580      #foreach my $e ( sort keys %_args ) { print "<BR> * $e = $_args{ $e } "; };
 581      #foreach my $f ( sort keys %{ $self } ) { print "<BR> + $f = $self->{ $f } "; };
 582      #print "<BR>Thing = '" . ref( $self ) . "'" ;
 583    
 584    # Connect to the DB
 585      my $dbh = DBI->connect( db_DB_funcs::connectString() );
 586    
 587      # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Set up QUERIES:
 588      # Get Security Levels
 589      my $SQL   = "SELECT a.ID
 590                   FROM v_users a
 591                      , security_levels b
 592                   WHERE
 593                        ( a.security_level & b.code OR b.code = 0 )
 594                    AND a.ID             = $_args{ user }
 595                    AND b.type           like ?
 596                    AND b.name           like ?";
 597      my $sth = $dbh->prepare( $SQL );
 598    
 599      my $ID;
 600      SELECT_ID:
 601        {
 602         $ID = $_args{ ID }      , last SELECT_ID if ref( $self ) =~ /counts/i;
 603         $ID = $_args{ ID }      , last SELECT_ID if $self->get( "thing" ) eq ""
 604                                                       and $self->get( "ID" ) eq "";
 605         $ID = $self->get( "ID" ), last SELECT_ID if $self->get( "thing" ) eq "";
 606         $ID = $self->get( "thing" );
 607        };
 608    
 609      my $_thing = o_things->new( ID => $ID );
 610    
 611      print "<HR>" unless $_args{ add_hr } =~ /no/i;
 612      my $name = ( $_args{ lang } =~ /spa/ ? "nombre" : "name" );
 613      my $thing_name = $_thing->get( "name" );
 614      $thing_name = ref( $_thing ) . " $ID" if $thing_name eq "";
 615    
 616      # Print a header for the Quicklinks
 617      if( $_args{ add_header } =~ /no/i )
 618      {
 619        print "<TABLE BORDER=0 ><TR><TD>";
 620      }
 621      else
 622      {
 623        print "<TABLE BORDER=0 WIDTH='100%'><TR>";
 624        print "<TD CLASS='bigtitle' COLSPAN=100 ALIGN='center'>"
 625                                           . "User Functions for '$thing_name'<TR>";
 626      }
 627      #my $_type = ( $_args{ type } =~ /misc/i
 628      #             ? $_thing->get_thing_type()
 629      #             : $_args{ type } );
 630      my $_type = $_thing->get_thing_type();
 631    
 632      my $_param_list = "ID="         . $ID;
 633      $_param_list   .= "&type="      . $_type;
 634      $_param_list   .= "&user="      . $_args{ user };
 635      $_param_list   .= "&user_name=" . $_args{ user_name };
 636      $_param_list   .= "&lang="      . $_args{ lang };
 637      $_param_list   .= "&sec_level=" . $_args{ sec_level };
 638      $_param_list   .= "&function="  ;
 639    
 640      my @_functions = ( "edit", "add", "distribute", "move", "load"
 641                        , "change_status", "request", "details" );
 642      foreach my $value ( @_functions )
 643      {
 644        my $temp = $value;
 645        $temp =~ s/_/ /g;
 646        my $_ret_val = $sth->execute( "$_type", "\%$temp\%");
 647        my $_count = 0;
 648        if( $_ret_val ne '0E0' )
 649        {
 650          my $CGI_file = ( ( $temp =~ /view/i
 651                            or $temp =~ /details/i )
 652                          ? "reports.cgi"
 653                          : "transactions.cgi"
 654                         );
 655          print "<TD ALIGN='center'><A CLASS='sm_link'
 656              HREF='$CGI_file?$_param_list$value'>" . ucfirst($temp) ."</A>"
 657                                          unless ( $_ret_val eq '0E0' )
 658                                              or ( $_thing->get( "is_unique" ) eq 0
 659                                                             and $value =~ /load/i )
 660                                              or ( $_type =~ /locat/i
 661                                                             and $value =~ /move/i )
 662                                              or ( $_type =~ /locat/i
 663                                                            and $value =~ /load/i );
 664        }
 665      }
 666      print "</TABLE>";
 667      print "<HR>" unless $_args{ add_hr } =~ /no/i;
 668    };
 669    
 670    
 671    sub filter_view
 672    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 673    # FFFFF IIIII TTTTTTT L     EEEEE RRRRR       V       V IIIII EEEEE W          #
 674    # F       I      T    L     E     R    R       V     V    I   E      W         #
 675    # FFFF    I      T    L     EEEE  RRRRR         V   V     I   EEEE    W   W   W#
 676    # F       I      T    L     E     R   R          V V      I   E        W W W W #
 677    # F     IIIII    T    LLLLL EEEEE R    R _____    V     IIIII EEEEE     W   W  #
 678    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 679    {
 680      my( $self, %_args ) = @_;
 681      my $type;
 682      SWITCH:{
 683               $type = "o_count", last if ref( $self ) =~ /item/;
 684             };
 685      my $thing = $type->new( );
 686      $thing->print_me( add_header=>'no');
 687    }
 688    
 689    
 690    sub filter_display
 691    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 692    # FFFFF IIIII TTTTTTT L     EEEEE RRRRR        DDDD   IIIII  SSSS PPPPP  L     #
 693    # F       I      T    L     E     R    R       D   D    I   S     P    P L     #
 694    # FFFF    I      T    L     EEEE  RRRRR        D    D   I    SSS  PPPPP  L     #
 695    # F       I      T    L     E     R   R        D   D    I       S P      L     #
 696    # F     IIIII    T    LLLLL EEEEE R    R _____ DDDD   IIIII SSSS  P      LLLLL #
 697    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#
 698    {
 699      my( $self, %_args ) = @_;
 700      my( $type, $func );
 701      SWITCH:{
 702               if( ref( $self ) =~ /item/ )
 703               {
 704                 $type = "o_count";
 705                 $func = "print_me";
 706                 last ;
 707               }
 708               if( ref( $self ) =~ /loca/ )
 709               {
 710                 $type = "o_locations";
 711                 $func = "what_is_in_me";
 712                 last ;
 713               }
 714             };
 715      my $thing = $type->new( );
 716      $thing->$func();
 717    }
 718    
 719    1;