#! /usr/bin/perl -w use strict ; use warnings ; use diagnostics ; use Data::Dumper ; $|++ ; my $sql_query = q( /**/ SELECT /**/ ASSET_ID /**/ , /**/ ASSET_DESC /**/ , /**/ ASSET_COST /**/ FROM /**/ SYNERGEN.SA_ASSET@/**/SGENQA/**/ /**/, /**/ SYNERGEN.SA_WORK_ORDER@/**/SGENTEST/**/ /**/ WHERE /**/ ASSET_ID IS NOT NULL /**/ AND /**/ ASSET_DESC IS NOT NULL /**/ AND /**/ ASSET_COST > 100 /**/ /**/ ) ; my @type_list = qw( FIELD DATABASE CONDITION FULL_TBL QUERY ) ; foreach my $type ( @type_list ) { my @list = &get_match_list( $type, $sql_query ) ; print Dumper( \@list ), "\n" ; } exit( 0 ) ; #----- F U N C T I O N S ---------------------------------------- sub start_tag { my $tag = shift ; my $start = "\\/\\*\\s*<$tag>\\s*\\*\\/" ; return $start ; } sub end_tag { my $tag = shift ; my $end = "\\/\\*\\s*<\\/$tag>\\s*\\*\\/" ; return $end ; } sub get_match_list { my ( $tag, $text ) = @_ ; my @match_list = () ; # create the start & end tags my ( $start, $end ) = ( &start_tag( $tag ), &end_tag( $tag ) ) ; # as long as you're finding tag pairs... while ( $text =~ m/$start\s*(.*?)\s*$end/gi ) { my $new_match = $1 ; # strip out any comments, and replace spaces on either end # with a single space (leaving line breaks alone) my $spc = $new_match =~ /[ \t]+\/\*.*?\*\/|\/\*.*?\*\/[ \t]+/ ? ' ' : '' ; $new_match =~ s/[ \t]*\/\*(.*?)\*\/[ \t]*/$spc/g ; # Strip any whitespace off the ends $new_match =~ s/^\s*(.*?)\s*$/$1/ ; push( @match_list, $new_match ) ; } return @match_list ; } #### $VAR1 = [ 'ASSET_ID', 'ASSET_DESC', 'ASSET_COST' ]; $VAR1 = [ 'SGENQA', 'SGENTEST' ]; $VAR1 = [ 'ASSET_ID IS NOT NULL', 'ASSET_DESC IS NOT NULL', 'ASSET_COST > 100' ]; $VAR1 = [ 'SYNERGEN.SA_ASSET@SGENQA', 'SYNERGEN.SA_WORK_ORDER@SGENTEST' ]; $VAR1 = [];