Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
PerlMonks  

Seekers of Perl Wisdom

( #479=superdoc: print w/replies, xml ) Need Help??

If you have a question on how to do something in Perl, or you need a Perl solution to an actual real-life problem, or you're unsure why something you've tried just isn't working... then this section is the place to ask. Post a new question!

However, you might consider asking in the chatterbox first (if you're a registered user). The response time tends to be quicker, and if it turns out that the problem/solutions are too much for the cb to handle, the kind monks will be sure to direct you here.

User Questions
Are there any modules using source filter to capture code?
1 direct reply — Read more / Contribute
by LanX
on Apr 29, 2017 at 17:47
Get url
3 direct replies — Read more / Contribute
by kepler
on Apr 29, 2017 at 17:25

    Hi

    I'm having some troubles regarding a simple get for an url, https://www.earthquake.usgs.gov/earthquakes/feed/v1.0/summary/2.5_week.atom

    Even using this script, I get a null result (in several hosts except one, bluehost):
    #!/usr/bin/perl use LWP::Simple; use warnings; print "Content-type: text/html\n\n"; my $url = "https://www.earthquake.usgs.gov/earthquakes/feed/v1.0/summa +ry/2.5_week.atom"; my $data = get $url; print "$url\n$data";

    Can someone help me out?

    Thanks, Kepler
Videos from LPW 2016?
No replies — Read more | Post response
by LanX
on Apr 29, 2017 at 15:59
using Skype
2 direct replies — Read more / Contribute
by louhevly
on Apr 29, 2017 at 13:19

    Greetings oh wise ones,

    My mother is in her 90s and lives alone in her own apartment in a retirement home in the States. I live in Europe and would like to write a Perl script that calls her landline phone every morning at 9am (this could be on a cronjob). If she answers, the program should report success and exit; if no answer, then call 10 minutes later. If after 30 minutes there is no answer, then call a different number requesting that someone check her room.

    My Skype account allows me to call Skype-to-landline for pennies, which is what I'm doing now manually. I searched for Skype on CPAN and found quite a number of modules described, but I thought it might save time asking here if someone knew just which module might be appropriate for what I'm trying to do.

    Thanks in advance, Lou

HASH value error
2 direct replies — Read more / Contribute
by pdahal
on Apr 29, 2017 at 01:58
    I am a beginner in perl. I need to parse an XML file and store the results into CSV file. The problem I am facing is I am getting the output like "HASH(0x3de3350)" instead of PubMed IDs like "16466327" in CSV file. How can i handle this?
Convert weekday to numerical date
3 direct replies — Read more / Contribute
by james28909
on Apr 28, 2017 at 23:23

    Hello again wise monks :)

    I have a list of weekdays:

    my @weekdays = qw( Today Yesterday Sunday Monday Tuesday Wednesday Thursday Friday Saturday Sunday );

    I need to format these weekdays into an absolute numerical date based off of scalar localtime. eg:

    my ($local_weekday, $local_month, $local_numerical_date) = split (/\s+ +/, scalar localtime), 3; __END__ Fri Apr 28 'Yesterday' would be '27'

    I need to use $local_weekday and $local_numerical_date (eg. 'fri 28') to format @weekdays from the list. eg. 'wednesday' to eg. '26'.

    Also, i never need to check what the numerical date in the future is, it is always current date or earlier. I am pretty sure there is a way to loop while subtracting but I cant figure it out lol.

    If I can be any more clear on anything please let me know. I have tried to explain it the best i can :)

    EDIT: changed 'wednesday 27' to just '27' and added 'Yesterday' would be '27' to __END__

Array of variables
7 direct replies — Read more / Contribute
by Michael W
on Apr 27, 2017 at 11:38
    my @Variables = ( $Map_Request_Date,$Map_Due_Date,$Map_Cutover_Date,$ +Map_Complete_Date,$Map_Approved_Date); foreach $Date_Ref (@Variables) { print $Date_Ref; $Date_Ref =~ s/ +/ /; #When day is a single digit it creates two wh +ite spaces ($Month,$Day,$Year,$Time)= split / /, $Date_Ref,4; my %Months = ( 'Jan' => '01', 'Feb' => '02', 'Mar' => '03', 'Apr' + => '04', 'May' => '05', 'Jun' => '06', 'Jul' => '07', 'Aug' + => '08', 'Sep' => '09', 'Oct' => '10', 'Nov' => '11', 'Dec' +=> '12' ); if (length($Day) == 1) {$Day = "0$Day";}#Add 0 to the front of sing +le digit days @Variable[$X]=$Year."-".$Months{$Month} ."-" . $Day ; $X=$X+1; }

    Working on a date issue from sql to html format

    previous only used an array of variables to read from

    this time I want to place the value back into the array of variables

    this line: @Variable$X=$Year."-".$Months{$Month} ."-" . $Day ;

    all the code works until I try to write the new variable back in

how i capture a script error to a file ?
5 direct replies — Read more / Contribute
by gabrielsousa
on Apr 27, 2017 at 08:28
    how i capture a script error to a file ?
    did this, but dont work :(
    local $SIG{__DIE__} = sub { my $message = shift; system qq(echo "$message" >> log.err); };
Convert KMail emails to Claws
4 direct replies — Read more / Contribute
by peterr
on Apr 27, 2017 at 01:41

    I'm using a Perl script to convery KMail emails to Claws email. There were a few errors

    #!/usr/bin/perl -w # * This file is free software; you can redistribute it and/or modify + it # * under the terms of the GNU General Public License as published by # * the Free Software Foundation; either version 2 of the License, or # * (at your option) any later version. # * # * This program is distributed in the hope that it will be useful, b +ut # * WITHOUT ANY WARRANTY; without even the implied warranty of # * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # * General Public License for more details. # * # * You should have received a copy of the GNU General Public License # * along with this program; if not, write to the Free Software # * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 021 +10-1301, USA. # * # * Copyright 2003-2007 Paul Mangan <paul@claws-mail.org> # * # * 2007-02-25: several fixes for kmail 1.9.6 # --kmaildir now expects the full path # renamed from maildir2claws-mail.pl to kmail-mailbox2claws-ma +il.pl # * 2003-10-01: add --debug and --dry-run options # * 2003-09-30: updated/improved by Matthias Förste <itsjustme@users. +sourceforge.net> # * 2003-05-27: version one ## script name : kmail-mailbox2claws-mail.pl ## script purpose : convert a Kmail mailbox into a Claws Mail mailbox ## USAGE: kmail-mailbox2claws-mail.pl --kmaildir=/full/path/to/kmail/m +ailbox ## tested with Kmail version 1.9.6 use strict; use Getopt::Long; use File::Find; my $kmaildir = ''; my $iNeedHelp = ''; # dont actually change anything if set(useful in conjunction with debu +g) my $PRETEND = ''; # print debug info if set my $DEBUG = ''; my $claws_tmpdir = "$ENV{HOME}/claws_tmp"; GetOptions("kmaildir=s" => \$kmaildir, "help" => \$iNeedHelp, "dry-run" => \$PRETEND, "debug" => \$DEBUG); if ($kmaildir eq "" || $iNeedHelp) { if (!$iNeedHelp) { print "No directory name given\n"; } print "Use the following format:\n"; print "\tkmail-mailbox2claws-mail.pl --kmaildir=full-path-to-kmail +-dir\n\n"; exit; } my $count = 1; my $MAIL_dir = "$kmaildir"; my $find_opts = { wanted => \&process }; if (-d $MAIL_dir) { find($find_opts , ($MAIL_dir)); } else { print "\n$MAIL_dir is not a directory !\n"; exit; } unless ($PRETEND) { mkdir("$claws_tmpdir", 0755); system("mv $claws_tmpdir $ENV{HOME}/Mail"); print "\n\nSucessfully converted mailbox \"$MAIL_dir\"\n"; print "Start claws-mail and right-click \"Mailbox (MH)\" and "; print "select \"Rebuild folder tree\"\n"; print "You may also need to run \"/File/Folder/Check for "; print "new messages in all folders\"\n\n"; } print "\n"; exit; sub process() { if (-d) { process_dir($File::Find::dir); } else { process_file($File::Find::name); } } sub process_dir() { my $direc = shift(); $DEBUG && print "\nDIR $direc"; if ($direc !~ m/^drafts$/ && $direc !~ m/^outbox$/ && $direc !~ m/^trash$/ && $direc !~ m/^inbox$/) { my $tmpdir = $direc; $tmpdir =~ s/^$MAIL_dir//; $tmpdir =~ s/\/sent-mail$/sent/; $tmpdir =~ s/\/cur$//; $tmpdir =~ s/\/new$//; $tmpdir =~ s/^\///; $tmpdir =~ s/\.directory//g; $tmpdir =~ s/\.//g; my $newdir = "$claws_tmpdir/$tmpdir"; $DEBUG && print qq{\n>>> -e "$newdir" || mkdir("$newdir")}; $PRETEND || -e "$newdir" || mkdir("$newdir"); } } sub process_file { my $file = shift; $DEBUG && print "\nFILE $file"; my $nfile; my $tmpfile = $file; $tmpfile =~ s|^$kmaildir||; if ($tmpfile =~ m/\/cur\// || $tmpfile =~ m/\/new\//) { $tmpfile =~ s/\/new//; $tmpfile =~ s/\/cur//; my @spl_str = split("/", $tmpfile); pop(@spl_str); push(@spl_str, "$count"); foreach my $spl_str (@spl_str) { $spl_str =~ s/\.directory$//; $spl_str =~ s/^\.//; $spl_str =~ s/^sent-mail$/sent/; } $nfile = join("/", @spl_str); $nfile = $claws_tmpdir.$nfile; } if (-e "$file" && $nfile ne "") { $DEBUG && print qq{\n+++ cp "$file" "$nfile"}; $PRETEND || system("cp \"$file\" \"$nfile\""); $count++; } }

    cp: cannot create regular file '/home/********/claws_tmp/*******/Misc. (PO,NRMA,etc)/711': No such file or directory

    Is this simply because the file is attempted to be copied before the path exists ? How do I fix that please

    Also this error ...

    Use of uninitialized value $nfile in string ne at kmail-mailbox2claws-mail.pl line 149.

    It is defined at libe 125, but not initialised; is that all that needs doing there ?

Unable to load the parser
1 direct reply — Read more / Contribute
by amitkumarj441
on Apr 26, 2017 at 16:28

    I have built a perl based application which can translate natural language to sql query and I'm testing it on Windows 7 using but here after running my perl script "sq-hal.pl"(code is given below) it unable to load the parser. Given below is the encountered error :

    Establishing connection to DBI:mysql:student ... Creating the parser... Reading table names... Table names: XS_Tk__Callback_Call error:Undefined subroutine &main::column_names_to +_parser_st r called at parser.pl line 38. Tk::Error: Undefined subroutine &main::column_names_to_parser_str call +ed at pars er.pl line 38. Parse::RecDescent::BEGIN at grammar_func.pl line 52 main::load_parser at parser.pl line 38 main::load_data at splash.pl line 81 Tk::After::once at C:/Dwimperl/perl/site/lib/Tk/After.pm line 90 [once,[{},after#27,10,once,[\&main::load_data]]] ("after" script)

    Given below are the scripts, Can anyone here help me in resolving this error?

    # sq-hal.pl use strict; # Required Modules use Tk; use Tk::Table; use Tk::Text; use Tk::Photo; use Tk::Balloon; # Global variables use vars qw ( $user_input ); # English query typed by the user use vars qw ( $win_sq_hal ); # the main window for SQGNL use vars qw ( $parser ); # SQGNL parser which contains all th +e grammar use vars qw ( $results ); # results of SQGNL parsing of the En +glish query use vars qw ( $save_parser ); # whether parser need to be required + at the end (0 or 1) use vars qw ( @learn_strs ); # temporary hold new grammar to be l +earned use vars qw ( $results_table ); # table to display database records use vars qw ( $status_text ); # status bar text to be displayed use vars qw ( $default_status_text ); # default status bar text use vars qw ( $txt_output ); # text area where the output of SQGN +L is displayed # SQGNL configuration variables use vars qw ( $user ); # user name to login to the database use vars qw ( $passwd ); # password for the database login use vars qw ( $db_source ); # database source use vars qw ( $db_type ); # type of database use vars qw ( $learn_enabled ); # enable/disable learning grammar (0 + - disable, 1 - enable) use vars qw ( $rows_displayed ); # number of rows from the results qu +ery to be displayed to the user use vars qw ( $config_file_found ); # status of the configuration file + (0 or 1) # Modular level variables my $txt_input; # text area for users to type the query # Combine all the required files and # load the subroutines from various files do "configure.pl"; # configuration window definitions load_config(); # load the configuration data from a file do "parser.pl"; # SQ-HAL parser definitions do "splash.pl"; # splash sceen definitions do "database.pl"; # definitions for various database functionalit +ies # if the configuration file is not found then # (either due to first-time running or confgureation file got deleted) # show the SQGNL confiugration window to get required info if ($config_file_found == 0) { show_config(); } do "login.pl"; # get database login password save_config(); # user name might have changed when login scree +n is # called. So save the new configuration data do "db_structure.pl"; # window definition to show/get database s +tructure do "create_sql.pl"; # window definition to create SQL statemen +ts manually do "learning.pl"; # window definition to display new grammar + to be learnt do "relationships.pl"; # window definition to display/get table r +elationships ### Show the splash screen while loading the parser ### ### as the parser may take some time to load ### show_splash(); ### Create and show the main SQGNL window ### create_main_window(); # Display the spalsh screen and load parser grammar in the background sub create_main_window { $win_sq_hal = MainWindow->new; # create the main SQGNL window $win_sq_hal->appname("SQGNL"); $win_sq_hal->title("SQGNL: The Natural Language to SQL Translator" +); ### maximize and position the SQGNL main window ### my $w = $win_sq_hal->screenwidth()-10; # window width = screen +width my $h = $win_sq_hal->screenheight()-100; # window height = screen + height $win_sq_hal->geometry("${w}x${h}+0+20"); ### define and place window controls ### my $tooltip = $win_sq_hal->Balloon( -statusbar => $status_text ); my $win_sq_hal1 = $win_sq_hal->Frame( -relief => 'flat', -borderwidth => 10) ->pack( -ipadx => 10, -fill => 'both', -expand => 1); $win_sq_hal1->Label( -text => "Type your question below:", -anchor => "sw") ->pack( -fill => "x"); ### user input text area ----------------------------------------- +------ $txt_input = $win_sq_hal1->Scrolled( 'Text', -scrollbars => 'e', -height => 2, -wrap => "word") ->pack( -side => "top", -fill => "x", -expand => 0); $tooltip->attach($txt_input, -msg => "Type your English query here and then pr +ess Tranlate button."); my $fra_buttons1 = $win_sq_hal1->Frame->pack( -side => 'top', -fill => 'x', -expand => 0 ); ### button to activate translate the English query --------------- +------ my $cmd_translate = $fra_buttons1->Button( -text => "Translate th +e query to SQL", -command => \&parse_inpu +t) ->pack( -side => "left", -ipadx => 10, -anchor => "ne"); $tooltip->attach($cmd_translate, -msg => "Translate the English query into SQL."); ### button to clear the content in the query text area ----------- +------ my $cmd_clear = $fra_buttons1->Button( -text => "Clear", -command => sub { ### delete everything i +n the text area ### $txt_input->delete("1.0 +", "end"); } ) ->pack( -side => "left", -ipadx => 10, -padx => 10, -anchor => "ne"); $tooltip->attach($cmd_clear, -msg => "Clear the text in the English query area +."); ### button to bring up the create_sql window --------------------- +------ my $cmd_create_sql = $fra_buttons1->Button( -text => "Create your +own SQL", -command => \&show_create +_sql) ->pack( -side => "right", -ipadx => 10, -anchor => "ne"); $tooltip->attach($cmd_create_sql, -msg => "Bring up the window where you can create + your own SQL statements with ease."); my $fra_output = $win_sq_hal1->Frame->pack( -side => 'top', -fill => 'x', -expand => 0 ); ### text area to display output results -------------------------- +------ $txt_output = $fra_output->Scrolled( 'Text', -scrollbars => 'e', -height => 3, -wrap => "word") ->pack( -side => "left", -anchor => "nw", -fill => "x", -expand => 1); $tooltip->attach($txt_output, -msg => "Translated SQL statments are displayed h +ere. You may can modify this and press execute button\n to see the results +of the SQL statment"); ### button to execute SQL in the txt_output area ----------------- +------ my $cmd_exec = $fra_output->Button( -text => "Execute SQL", -command => sub { ### copy the content of th +e txt_output ### ### (SQL statement) to the + varaiable $results ### $results = $txt_output->ge +t("1.0", "end"); ### execute SQL and show t +he results ### if ( $results ne "") { show_data(); } } ) ->pack( -side => "right", -ipadx => 10, -pady => 10, -anchor => "ne"); $tooltip->attach($cmd_exec, -msg => "Execute the SQL statment and display the + results."); ### $status_text bar text area ----------------------------------- +------ $default_status_text = "SQ-HAL: The Natural Language to SQL Transl +ator"; $status_text = $default_status_text; $win_sq_hal->Label( -textvariable => \$status_text, -relief => "sunken", -anchor => "nw", -borderwidth => 2) ->pack( -side => "top", -fill => "x", -padx => 10, -expand => 0); my $fra_buttons2 = $win_sq_hal1->Frame ->pack( -side => "bottom"); ### button to bring up the database structure window ------------- +------ my $cmd_database = $fra_buttons2->Button( -text => "Database", -underline => 1, -command => \&show_databa +se) ->pack( -fill => "x", -ipadx => 20, -padx => 10, -pady => 5, -side => "left", -expand => 0); $tooltip->attach($cmd_database, -msg => "Display the current database structure." +); ### button to bring up the configuration window ------------------ +------ my $cmd_config = $fra_buttons2->Button( -text => "Configure", -underline => 2, -command => \&show_config) ->pack( -fill => "x", -side => "left", -ipadx => 20, -padx => 10, -pady => 5, -expand => 0); $tooltip->attach($cmd_config, -msg => "Configure SQ-HAL."); ### button to exit to the system --------------------------------- +------ my $cmd_exit = $fra_buttons2->Button( -text => "Exit", -underline => 1, -command => \&exit_sq_hal ) ->pack( -fill => "x", -ipadx => 40, -padx => 10, -pady => 5, -side => "left"); $tooltip->attach($cmd_exit, -msg => "End SQ-HAL and Exit to the system."); ### table to display results from the SQL statements ------------- +------ $results_table = $win_sq_hal1->Table( -rows => 1, -columns => 1, -scrollbars => "se", -relief => "groove", -borderwidth => 2, -fixedrows => 1) ->pack( -side => "top", -fill => "both", -expand => 1); $tooltip->attach($results_table, -msg => "Display data retrieved from the database +."); ### exit the program when destroying this main window ############ +###### $win_sq_hal->bind("<Destroy>", \&exit_sq_hal); ### set the focus to the query entering area ### $txt_input->focus; ### display this window and start handling events ### MainLoop; } # parse user input and show results sub parse_input { ### update the statusbar text ### $status_text = "Translating the English statement to a SQL stateme +nt..."; $win_sq_hal->update(); ### the input and output files and commented lines below ### ### are used for testing purposes only ### #my $inputFile = "data.txt"; #my $outputFile = "output.txt"; #open(DATA, "< $inputFile") || die $!; #open(OUT, "> $outputFile") || die $!; #while (<DATA>) #{ # if (!/^#/ && !/^[\s]*\n/) # Ignore commented lines and +empty lines # { # print "> "; # sleep 1; # print; ### copy the English query to the variable $user_input ### $user_input = $txt_input->get("1.0", "end"); ### remove special characters from the input ### $user_input =~ s/[:.'?!]//g; ### translate the user query to SQL ### eval{ $results = $parser->translate("\L$user_input"); }; ### clear the current content of the output area and insert new tr +anslated SQL ### $txt_output->delete("1.0", "end"); $txt_output->insert("end", $results); $_ = $results; ### if the first word of the results is "SELECT" then it is an + ### ### SQL statement. Otherwise it is and untranslated error message + ### if (/^SELECT/) { ### display the SQL statement in bule colour ### $txt_output->configure( -foreground => "blue" ); ### execute SQL and show the results ### show_data(); ### if there are anything to be leart, then display the learni +ng window ### if ($#learn_strs >= 0) { show_learn(); } } else ### English query not translated into SQL ### { ### if the learning is enabled, then add this English query ## +# ### to the query list that to be learnt ## +# if ($learn_enabled) { $learn_strs[++$#learn_strs] = "\L$user_input"; } ### display the error message in red ### $txt_output->configure( -foreground => "red" ); } ### update window controls ### $win_sq_hal->update(); ### save the results in the outupt file ### #print OUT $user_input, $results, "\n"; # } #} ### close all the open files ### #close(DATA); #close(OUT); ### update the statusbar with default text ### $status_text = $default_status_text; $win_sq_hal->update(); } # retrieve data from the database and display on to the screen sub show_data() { ### change the mouse icon to be busy icon ### $win_sq_hal->Busy; ### update statusbar text ### $status_text = "Retrieving data from the database..."; $txt_output->configure( -foreground => "blue" ); $win_sq_hal->update(); ### execute the SQL results ### ### this will update the results table as well ### execute_sql( $results ); ### update status bar text back to default ### $status_text = $default_status_text; ### change the mouse icon back to normal ### $win_sq_hal->Unbusy; } ### used as a flag to determine the exit function is called once ### ### multiple calls to the function is posible if the user press ### ### exit button as well as destorying the window calls the func. ### my $already_exited = 0; # exit SQGNL by disconnecting from the database and saving the parser sub exit_sq_hal { ### do not repeat this subroutine twice ### if ($already_exited) { return } $already_exited = 1; ### change the mouse icon to be busy icon ### $win_sq_hal->Busy; ### disconnect the current database connection ### disconnect_from_db(); ### if required, save the parser to a file ### if ($save_parser) { ### update statusbar text $status_text = "Saving the parser to a file. Please wait..."; $win_sq_hal->update; save_parser(); } ### save database structure to a file ### #save_db_info(); ### exit to the system ### exit; }
    # parser.pl use strict; # Global variables use vars qw( %table_columns ); use vars qw( %table_relationships ); # Modular level variables ### Following variables used to test this parser only ### my $dataFile = "data1.txt"; ### Input Data file (for testing) + ### my $outputFile = "output.txt"; ### Output results file (for testin +g) ### my $debug_on = 0; ### Enable testing of this parser + ### my $trace_on = 0; ### Enable tracing the parser outpu +t ### my $grammar; ### SQGNL parser grammar + ### my $parser_file; ### name of the file which contains + parser object ### # combine table names into parser accepted string sub load_parser { $parser_file = "sq_hal_${db_type}_${db_source}_${user}"; ### replace invalid names in the file name ### $parser_file =~ s/[\\\/:*?<>|]//g; ### if parser file not found then load grammar ### if (!eval{require "${parser_file}.pm"}) { print "Creating the parser...\n"; ### Create the grammar ### $grammar = do "grammar.pl" or warn "Bad Grammar!"; ### Replace table_names ### my $tables_str = table_names_to_parser_str(); $grammar =~ s/TABLES/$tables_str/; ### Replace column names ### my $columns_str = column_names_to_parser_str(); $grammar =~ s/FIELDS/$columns_str/; } else { print "Loading the parser from the file '${parser_file}.pm'... +\n"; do "grammar_func.pl"; } ### initialize variables such as database structure, etc. ### initialize_vars(); use Parse::RecDescent; ## Enable tracing of the parser ### if ($trace_on) { $RD_TRACE = 1; } ### Load the parser from the file or ### ### create the parser if the file is not available ### $parser = eval{require "${parser_file}.pm"} ? $parser_file->new() : Parse::RecDescent->new($grammar) or warn "Bad Parser!"; ### if the parser file is not found, then the parser need to be sa +ved ### if (!eval{require "${parser_file}.pm"}) { $save_parser = 1; } ### if testing this parser only then do the following code ### if ($debug_on) { ### Open the input data file open(DATA, "< $dataFile") || die $!; open(OUT, "> $outputFile") || die $!; $| = 1; ### Parse each line of data ### while (<DATA>) { if (!/^#/ && !/^[\s]*\n/) ### Ignore commented or empty + lines ### { print "> "; #sleep 1; print; ### Translate the grammar ### my $SQL = $parser->translate("\L$_"); ### Print the translated output to the screen and outp +ut file ### print "$_$SQL\n"; print OUT "> $_$SQL\n"; } else { print OUT "$_"; } } ### Close files ## close(DATA); close(OUT); ### Exit to the system ### exit; } } # save the parser to a file sub save_parser() { print "Saving the parser to the file '${parser_file}.pm'..."; ### if exist, then delete the parser file ### if (eval{require "${parser_file}.pm"}) { eval { unlink "${parser_file}.pm"; }; } ### save the parser to file ### eval { $parser->Save($parser_file); }; ### do not need to save the parser in the near future again ### $save_parser = 0; } # learn new rule by the parser sub extend_parser { my ($rule, $str) = ($_[0], $_[1]); ### parser rule and the new le +arn string ### my $grammar = qq{ $rule : $str }; ### new grammar to be learn ## +# $parser->Extend($grammar); ### extend the parser grammar +### #$save_parser = 1; ### parser has been changed and therefore nee +d to save ### ### print the newly learn grammar ### print "Learn grammar:\n$grammar\n"; } # initialize table relationships and table-column relationships sub initialize_vars { @table_columns{get_table_names()} = (); foreach my $table (keys(%table_columns)) { my %tmp; @tmp{get_column_names($table)} = (); foreach (keys(%tmp)) { $tmp{$_} = "1"; } $table_columns{$table} = { %tmp }; } ### load the table relationships from the file ### if (open(DB, "${parser_file}.db")) { ### read each of the table relationship ### while (<DB>) { chomp($_); next unless s/^(.*?):\s*//; my $tbl1 = qq{$1}; for my $field ( split /;/ ) { my ($tbl2, $val) = split(",", $field); $table_relationships{ qq{$tbl1} }{ qq{$tbl2} } = qq{$v +al}; } } close(DB); ### close the file ### } } # combine table names into parser accepted string sub save_db_info() { open(DB, "> ${parser_file}.db"); ### save each table relationship to a file foreach my $tbl1 (keys(%table_relationships)) { print DB "$tbl1:"; foreach (keys(%{$table_relationships{$tbl1}})) { print DB "$_,", $table_relationships{$tbl1}{$_},";" ; } print DB "\n"; } close(DB); ### close the file ### } # combine table names into parser accepted string sub table_names_to_parser_str() { print "Reading table names...\n"; ### Get table names for the current database ### %table_columns = (); @table_columns{get_table_names()} = (); print " Table names: ", join(", ", keys(%table_columns)), "\n\n +"; ### Create the parser recognised string ### my $tables_str = ""; foreach my $table ( keys(%table_columns) ) { ### table words need to be lower case ### my $table_words = "\L${table}?"; $tables_str .= "/${table_words}/{'${table}'}|"; } chop($tables_str); ### Remove the last '|' character ### return $tables_str; } # combine all table columns into parser accepted string sub column_names_to_parser_str() { use Lingua::EN::Inflect ':ALL'; ### read column names for each table ### my $columns_str = ""; foreach ( keys(%table_columns) ) { if ( $_ ) { print "Read column names for '$_'...\n"; my $current_table = $_; ### Get the column names for the given table ### my @columns = get_column_names($_); print " Column names: ", join(", ", @columns), "\n\n"; ### Create parser recognised string ### foreach my $column (@columns) { ### column words need to be lower case ### my $column_words = "\L" . PL_N($column) . "|$column"; $columns_str .= "/${column_words}/{'${column}'}|"; } } } chop($columns_str); ### Remove the last "|" character ### return $columns_str; } 1; ### so the 'do' command succeeds ###
    # splash.pl use strict; # Modular level variables use vars qw( $win_splash ); # window handle for this splash scree +n my $PARSER_FILE = "parser.pl"; # name of the parser file my $splash_shown = 0; # splash screen is already shown or n +ot my $splash_info; # message to be displayed on the spla +sh screen # Display the spalsh screen and load parser grammar in the background sub show_splash { ### do not show the splash screen if already shown ### ### we do not want to load the grammar twice ### if ($splash_shown == 1) { return 0; } $splash_shown = 1; ### splash screen has been shown ### ### create splash screen ### $win_splash = MainWindow->new(); ### do no show the title bar for the splash screen ### $win_splash->overrideredirect(1); $win_splash->configure( -background => "white"); $win_splash->configure( -borderwidth => 1); ### center this window ### my $h = 270; ### window height ### my $w = 360; ### window width ### my $x = int(($win_splash->screenwidth()-$w)/2); ### x positi +on ### my $y = int(($win_splash->screenheight()-100-$h)/2); ### y positi +on ### $win_splash->geometry("${w}x${h}+${x}+${y}"); ### create window controls ### my $img_sq_hal = $win_splash->Photo( -file => 'splash.gif'); ### SQGNL image ### $win_splash->Label( -borderwidth => 0, -image => $img_sq_hal )->pack; ### display area for splash screen messages ### $win_splash->Label( -textvariable => \$splash_info, -background => "white") ->pack( -fill => "x", -side => "top"); ### Exit button - to exit to the system ### $win_splash->Button( -text => " Exit ", -background => "white", -borderwidth => 0, -command => sub { exit }) ->pack( -fill => "x", -side => "top"); ### show spalsh screen ### $win_splash->update(); $win_splash->raise(); # start loading the parser immediately after displaying the splash + screen ### $win_splash->after(10, \&load_data); MainLoop; } # Load initial data and the parser at startup sub load_data { ### connect to the database ### $splash_info = 'Connecting to the database...'; $win_splash->update(); ### if unsuccessful database connection, then exit the program ### if (! connect_to_db($db_type, $db_source, $user, $passwd )) { exit; } ### load SQGNL parser ### $splash_info = 'Loading SQ-HAL parser...'; $win_splash->update(); load_parser(); ### Destroy the splash screen ### $win_splash->destroy(); } 1; # so the 'do' command succeeds

Add your question
Title:
Your question:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    Jar. Jar!...

    How do I use this? | Other CB clients
    Other Users?
    Others musing on the Monastery: (3)
    As of 2017-04-30 00:20 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      I'm a fool:











      Results (534 votes). Check out past polls.