Login
Important alert: (current site time 7/15/2013 9:32:14 PM EDT)
 

VB icon

IsDate - PerlTk

 Email
Submitted on: 8/10/2003 11:59:53 PM
By: Randy McCleary 
Level: Intermediate
User Rating: By 7 Users
Compatibility: 5.0 (all versions), Active Perl specific
Views: 12914
(About the author)
 
     This is an example of using PerlTk with my IsDate Function. Shows how to create GUI's on a Windows OS System using Tk.

 
code:
Can't Copy and Paste this?
Click here for a copy-and-paste friendly version of this code!
 
Terms of Agreement:   
By using this code, you agree to the following terms...   
  1. You may use this code in your own programs (and may compile it into a program and distribute it in compiled format for languages that allow it) freely and with no charge.
  2. You MAY NOT redistribute this code (for example to a web site) without written permission from the original author. Failure to do so is a violation of copyright laws.   
  3. You may link to this code from another website, but ONLY if it is not wrapped in a frame. 
  4. You will abide by any additional copyright restrictions which the author may have placed in the code or code's description. 
				
=**************************************
= Name: IsDate - PerlTk
= Description:This is an example of using PerlTk with my IsDate Function. Shows how to create GUI's on a Windows OS System using Tk.
= By: Randy McCleary
=
=This code is copyrighted and has= limited warranties.Please see http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=518&lngWId=6=for details.=**************************************

#!/usr/bin/perl -w
############################################
## An Example of how to create GUI's
## in perl with the Tk package
############################################
use strict;
use Tk;
use POSIX;
use Time::Local;
	
	
	
############################################
## 1. Create a New Window
## 2. Set the Window Size
## 3. Set the title of the window
############################################
my $main = MainWindow->new;
$main->geometry("359x283+8+8");
$main->title("IsDate() in PerlTk By - Randy McCleary");
	
	
	
############################################
## Now We are creating a Lable
##		-anchor = The position of the Text
##		 inside the Label, options are:
##		 (n,ne,nw,s,sw,se,e,w) All are
##		 Directions n = North, s = South
##		 and so on, get the point?
##		-text = The text displayed in the label
##		-background = labels background color
##		-cursor = Specifies the mouse cursor to 
##		 be used for the widget. The value 
##		 may have any of the forms acceptable
##		 to Tk_GetCursor
##		-font = Font of the text in the label
##		-foreground = This is the font color
############################################
my $label = $main->Label(
				 -anchor => "w",
				 -text => "Input a Date to Validate:", 
				 -background => "#D4D0C8", 
				 -cursor => "", 
				 -font => "Tahoma 10 bold",
				 -foreground => "#000077"
				 )->pack;
	
	
############################################
## Now We are going to specify where to 
## place the label we just created on to
## the form, so we set the width and height
## of the label and give x/y coordinates
## of where to place it at.
############################################ 
$label->place(
		 -width => 160, 
		 -height => 16, 
		 -x => 8, 
		 -y => 8
		 );
	
	
############################################
## Now we are going to create and Entry box
## aka. TextBox or InputBox. We will use 
## this to grab the input to check if the
## inputted date string is in valid format.
############################################
my $txtInput = $main->Entry(
				 -borderwidth => 1, 
				 -cursor => "", 
				 -font => "Tahoma 8 normal", 
				 -foreground => "#000000", 
				 -relief => "sunken"
				 )->pack;
	
$txtInput->place(
			-width => 152, 
			-height => 24, 
			-x => 8, 
			-y => 32
			); 
	
	
############################################
## Next We create a Button aka CommandButton
## this is what we will use to call the
## IsDate Sub when this button is clicked on
##	 -command = This calls the sub.
##		sub{sub_name_here(input1, input2)}
##		and so on, you can have more than 1
##		input or have no inputs.
##	Without arguments:
##		-command => \&subname
##		-command => sub { ... }
##		-command => 'methodname'
##	or with arguments:
##		-command => [ \&subname ?, args ...? ]
##		-command => [ sub { ... } ?, args...? ]
##		-command => [ 'methodname' ?, args...?]
############################################ 
my $cmdIsDate = $main->Button(
				 -activebackground => "#FFFCBF", 
				 -activeforeground => "#E30229", 
				 -background => "#FFFFFF", 
				 -borderwidth => 1, 
				 -text => "Validate Date", 
				 -command => sub{IsDate($txtInput)},
				 -cursor => "", 
				 -font => "Tahoma 8 bold", 
				 -foreground => "#140F7B", 
				 -relief => "solid"
				 )->pack;
	
	
############################################
## Place the button on the form
############################################ 
$cmdIsDate->place(
			-width => 104, 
			-height => 24, 
			-x => 176, 
			-y => 32
			);
	
	
############################################
## Now we create a Label just to display
## the Text "The Date is:"
############################################
my $lblDisplay = $main->Label(
				 -anchor => "w",
				 -text => "The Date is: ", 
				 -background => "#D4D0C8", 
				 -cursor => "", 
				 -font => "Tahoma 8 bold"
				 );
	
	
$lblDisplay->place(
			-width => 96, 
			-height => 24, 
			-x => 8, 
			-y => 80
			);
		
		
############################################
## Now we create a Label to store the value
## thats returned from the sub IsDate
## this will display True/False.
############################################ 
my $lblDate = $main->Label(
				 -anchor => "w", 
				 -borderwidth => 1, 
				 -text => "", 
				 -background => "#FFFFFF", 
				 -cursor => "", 
				 -font => "Tahoma 8 normal",
				 -relief => "solid",
				 -highlightbackground => "#000000", 
				 -justify => "right"
				 )->pack;
	
	
	
$lblDate->place(
			-width => 128, 
			-height => 24, 
			-x => 120, 
			-y => 80
			); 
	
		
my $lblHead = $main->Label(
				 -anchor => "w",
				 -text => "Valid Formats Below:", 
				 -background => "#D4D0C8", 
				 -cursor => "", 
				 -font => "Tahoma 8 bold"
				 );
	
		
$lblHead->place(
			-width => 216, 
			-height => 24, 
			-x => 16, 
			-y => 110
			);
			
	
############################################ 
## Creating a Text String to display all
## the valid date formats in a label
############################################ 
my $strText = ("1. 10/20/2003-mm/dd/yyyy
2. 10-20-2003-mm-dd-yyyy
3. 20/10/2003-dd/mm/yyyy
4. 20-10-2003-dd-mm-yyyy
5. 2003-10-20-yyyy-mm-dd
6. Thursday, June 26, 2003
7. Sat Oct 25 14:23:17 2003");
		
		
############################################ 
## Now we are creating a label to display
## the string variable generated above. This
## will put all the valid date formats in
## the label to display to the user.
############################################
my $lblNotes = $main->Label(
				 -anchor => "nw", 
				 -borderwidth => 1, 
				 -text => $strText, 
				 -background => "#D4D0C8", 
				 -cursor => "", 
				 -font => "Tahoma 8 normal", 
				 -justify => "left", 
				 -relief => "sunken"
				 )->pack; 
				 
$lblNotes->place(
			-width => 312, 
			-height => 112, 
			-x => 16, 
			-y => 136
			);
MainLoop;
		
		
		
########################################################
## Now we place all the subs below here. Which we only
## have one sub so it is below. But if we had more than
## one sub, then it could go anywhere just as long as
## its below the MainLoop;
########################################################
sub IsDate {
	###########################
	## Retrieve the input Data
	###########################
	my ($Input) = @_;
	my $dtmDate = $Input->get;
	
	###########################
	my $strDays = "Sunday|Monday|Tuesday|Wednesday|Thursday|Friday|Saturday";
	my $strAbbrDays = "Sun|Mon|Tue|Thu|Fri|Sat";	
	my $strMons = "January|February|March|April|May|June|July|
						August|September|October|November|December";
	my $strAbbrMons = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";
	my @arrMonths = ("January","February","March","April","May","June","July",
	 "August","September","October","November","December");
	my @arrAbbrMonths = ("Jan","Feb","Mar","Apr","May","Jun",
								"Jul","Aug","Sep","Oct","Nov","Dec");
	my @arrDays = ("Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday");
	my $strDay = '';
	my $intMonth = -1;
	my ($sec,$min,$hour,$day,$month,$year,$wday,$mhour) = 0;
	my ($DateTime, $WeekDayName, $i, $strTheMonth) = 0;
	my $strReturn = '';	
		
	### 10/20/2003
	if ($dtmDate =~ /^(\d{1,2})(\/|-)(\d{1,2})\2(\d{4})$/) {
		if (($1 < 1 || $1 > 12) && ($3 < 1 || $3 > 12)) {
			$strReturn = "False";
		}
	
		if (($3 < 1 || $3 > 31) && ($3 < 1 || $3 > 31)) {
			$strReturn = "False";
		}
	
		if ((($1==4 || $1==6 || $1==9 || $1==11) && $3==31) || (($3==4 || $3==6 || $3==9 || $3==11) && $1==31)) {
			$strReturn = "False";
		}
	
		if ($1 == 2) {
			if ($3>29 || ($3==29 && !($4 % 4 == 0 && ($4 % 100 != 0 || $4 % 400 == 0)))) {
				$strReturn = "False";
			}
		}
	}
	### 2003-10-20
	elsif ($dtmDate =~ /^(\d{4})(\-)(\d{1,2})\2(\d{1,2})$/) {
		if ($3 < 1 || $3 > 12) {
			$strReturn = "False";
		}
	
		if ($4 < 1 || $4 > 31) {
			$strReturn = "False";
		}
	
		if (($3==4 || $3==6 || $3==9 || $3==11) && $4==31) {
			$strReturn = "False";
		}
	
		if ($3 == 2) {
			if ($4>29 || ($4==29 && !($1 % 4 == 0 && ($1 % 100 != 0 || $1 % 400 == 0)))) {
				$strReturn = "False";
			}
		}
	}
	### Thursday, June 26, 2003
	elsif ($dtmDate =~ /^($strDays), ($strMons) (\d{1,2}), (\d{4})$/i) {
		### The Input has a valid Date Format, now its time to Validate
		### the inputted to date to see is a Valid Date
		
		
		$strTheMonth = $2;
		foreach (@arrMonths) {
			if ($_ eq ucfirst(lc($strTheMonth))) {
				$intMonth = $i;
				last;
			}	
			$i++;
		}
		
		if ($intMonth > 11 || $intMonth < 0) { 
			$strReturn = "False";
		}
		
		### If the days in the month for April, June, September, November equals 31
		###then the input date is invalid.
		if (($intMonth==4 || $intMonth==6 || $intMonth==9 || $intMonth==11) && $3==31) {
			$strReturn = "False";
		}
		
		### If Leap Year then allow the days in the month of february to be 29, else only
		### allow the number of days to be 28.
		if ($intMonth == 1) {
			if ($3>29 || ($3==29 && !($4 % 4 == 0 && ($4 % 100 != 0 || $4 % 400 == 0)))) {;
				$strReturn = "False";
			}
		}
		
		### Convert the DateTime to Seconds so you can use Perl's localtime function.
		### Use Perl's localtime function to get the week day to verify if the date is valid.
		$DateTime = timelocal(0,0,0, $3, $intMonth, $4);
		($sec,$min,$hour,$day,$month,$year,$wday) = localtime($DateTime);
		
		### Set the WeekDay Name from the $wday(0-6) from localtime.
		$WeekDayName = ("Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday")[$wday];
	
	
		### If the Inputted WeekDay name isn't the same as what was returned from Perl's
		### localtime function then the input date is invalid.
		#$strDay = $1;
		my $strDay = ucfirst(lc($1));
			
		if ($strDay ne $WeekDayName) {
			$strReturn = "False";
		}
	}
	### Sat Oct 25 14:23:17 2003
	elsif ($dtmDate =~ /^($strAbbrDays) ($strAbbrMons) (\d{1,2}) (\d{2}):(\d{2}):(\d{2}) (\d{4})$/i) {
		### The Input has a valid Date Format, now its time to Validate
		### the inputted to date to see is a Valid Date
		### Code to Validate the Date String
			
			
		$strTheMonth = $2;
		foreach (@arrAbbrMonths) {
			if ($_ eq ucfirst(lc($strTheMonth))) {
				$intMonth = $i;
				last;
			}	
			$i++;
		}
		
		if ($intMonth > 11 || $intMonth < 0) { 
			$strReturn = "False";
		}
		
		### If the days in the month for April, June, September, November equals 31
		###then the input date is invalid.
		if (($intMonth==4 || $intMonth==6 || $intMonth==9 || $intMonth==11) && $3==31) {
			$strReturn = "False";
		}
		
		### If Leap Year then allow the days in the month of february to be 29, else only
		### allow the number of days to be 28.
		if ($intMonth == 1) {
			if ($3>29 || ($3==29 && !($7 % 4 == 0 && ($7 % 100 != 0 || $7 % 400 == 0)))) {
				$strReturn = "False";
			}
		}
		
		if ($4>=24 || $4<0 || $5>=60 || $5<0 || $6>=60 || $6<0) {
			$strReturn = "False";
		}
		
		### Convert the DateTime to Seconds so you can use Perl's localtime function.
		### Use Perl's localtime function to get the week day to verify if the date is valid.
		$DateTime = timelocal($6, $5, $4, $3, $intMonth, $7);
		($sec,$min,$hour,$day,$month,$year,$wday) = localtime($DateTime);
			
			
		### Set the WeekDay Name from the $wday(0-6) from localtime.
		$WeekDayName = ("Sun","Mon","Tue","Wed","Thu","Fri","Sat")[$wday];
	
	
		### If the Inputted WeekDay name isn't the same as what was returned from Perl's
		### localtime function then the input date is invalid.
		#$strDay = $1;
		my $strDay = ucfirst(lc($1));
	
		if ($strDay ne $WeekDayName) {
			$strReturn = "False";
		}
	}
	else {
		$strReturn = "False";
	}
	
	######################################
	## If the return string is not equal
	## to False then the date inputted is
	## valid so set it to True
	######################################
	if ($strReturn ne "False") {
		$strReturn = "True";
	}
	
	######################################
	## Now we are changing the Text in
	## lblDate, to show if the Date string
	## is valid or not. True/False
	######################################
	$lblDate->configure(-text => $strReturn);
	
}


Other 28 submission(s) by this author

 
Report Bad Submission
Use this form to tell us if this entry should be deleted (i.e contains no code, is a virus, etc.).
This submission should be removed because:
Your Vote

What do you think of this code (in the Intermediate category)?
(The code with your highest vote will win this month's coding contest!)
Excellent  Good  Average  Below Average  Poor (See voting log ...)
 
Other User Comments
9/15/2003 12:20:17 PM: ICode

Nice, thanks for the code. Perl is becoming more and more interesting every day.
(If this comment was disrespectful, please report it.)
 
Add Your Feedback
Your feedback will be posted below and an email sent to the author. Please remember that the author was kind enough to share this with you, so any criticisms must be stated politely, or they will be deleted. (For feedback not related to this particular code, please click here instead.)
 

To post feedback, first please login.

Search:

Newest postings for Perl.

Add this ticker to my site

Daily code email

Click here to join the 'Code of the Day' mailing list!

This site on CD

Over 7,000 submissions on a super fast CD!

Code/Articles

Top Code

Community

Jobs

Other

Goto…

Copyright© 1997-2013 by Exhedra Solutions, Inc. All Rights Reserved.
By using this site you agree to its Terms and Conditions. Planet Source Code™ and the phrase "Dream It. Code It"™ are trademarks of Exhedra Solutions, Inc.