CGI程式範例 by perl 訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。:
訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。 [size=-1]
#!/usr/bin/perl [size=-1]
$date=`date`;
[size=-1]# HTTP HEADER
print "Content-type: text/html\n\n";
[size=-1]# PAGE
print
qq|
<html>
<head>
<meta http-equiv="Content-Type" c>
</head>
<body bgcolor="#FFFFFF">
<center>
This is a my first CGI program.
<br>
Nowtime is
$date
</center>
</body>
</html>
|;
[size=-1]exit(0);
訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。:
訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。 [size=-1]#!/usr/bin/perl
use CGI qw(:standard); [size=-1]
@colornum=qw(ff e0 c0 a0 80 60 40 20 00);
[size=-1]
$c=param('c');[size=-1] #color
if ( $c eq "" ) {
$c="808080";
}
[size=-1]# HTTP HEADER
print "Content-type:text/html\n\n";
# PAGE
print qq|
<html>
<head>
<meta http-equiv="Content-Type" c>
<title>html色彩號碼表</title>
</head>
[size=-1]<body bgcolor=#ffffff>
<center>
<font color=#cc0000>html色彩號碼表</font>
<table width="90%" bgcolor=#$c>
|;
[size=-1]
foreach $R (@colornum) {[size=-1]
foreach $G (@colornum) {
print "<tr>";
foreach $B (@colornum) {
print qq|
<td>
<a href=/cgi-bin/cgiwrap/~tung/ex2.pl?c=$R$G$B>#</a>
<font color=#$R$G$B>$R$G$B</font>
</td>
|;
}
print "</tr>\n";
}
}
[size=-1]print qq|
</table>
</center>
</body>
</html>
|;
訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。 訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。 訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。 [size=-1]#!/usr/bin/perl
use CGI qw(:standard); [size=-1]
$name=param('name');
$message=param('message');
[size=-1]#判斷是否有填 name, message
if ( $name eq "" || $message eq "" ) {
# HTTP HEADER
print "Content-type:text/html\n\n";
# PAGE
print qq|
<html>
<head>
<meta http-equiv="Content-Type" c>
<title>Error Input</title>
</head>
<body bgcolor=#ffffff>
<center> 姓名, 留言 欄位都要填, 不可以空白啦 </center>
</body>
</html>
|;
exit(0);
}
[size=-1]# HTTP HEADER
print "Content-type:text/html\n\n";
# PAGE
print qq|
<html>
<head>
<meta http-equiv="Content-Type" c>
<title>Right Input</title>
</head>
<body bgcolor=#ffffff>
[size=-1]姓名:
$name
<br>
留言:<pre>
$message</pre>
[size=-1]</body>
</html>
|;
[size=-1]exit(0);
訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。 訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。 [size=-1]1 #!/usr/bin/perl
2
use CGI qw(:standard);
3
4 $scripturl="/cgi-bin/cgiwrap/~tung/msglist.pl";
5 $msgdir="/home1/users/tung/public_html/cgi-bin/msg";
6
7 $name=param('name');
8 $message=param('message');
9 $action=param('action');
10
11 if ($action eq "msgadd_html") {
12 msgadd_html();
13 } elsif ($action eq "msgadd") {
14 msgadd($name, $message);
15 } else {
16 msglist();
17 }
18
19 exit 0;
20
21 ##########################################################
22
23
sub msglist {
24 # HTTP HEADER
25
print "Content-type: text/html\n\n";
26 # PAGE HEADER
27 print qq|
28 <html>
29 <head>
30 <meta http-equiv="Content-Type" c>
31 <title>留言板</title>
32 </head>
33 <body bgcolor=#ffffff>
34 <br>
35 <center><a href="$scripturl?action=msgadd_html">[我有話要說]</a></center>
36 <br>
37 |;
38 # PAGE CONTENT (msgs ordered by most recently first)
39
opendir (MSGDIR, $msgdir);
40 foreach $msgfile (
reverse (sort readdir(MSGDIR))) {
41 if ( $msgfile !~ /^\./ ) {
42 catfile($msgdir."/".$msgfile);
43 }
44 }
45
closedir(MSGDIR);
46
47 # PAGE END
48 print qq|</body></html>|;
49 }
50
51
52
sub msgadd_html {
53 # HTTP HEADER
54
print "Content-type: text/html\n\n";
55 # PAGE
56 print qq|
57 <html>
58 <head>
59 <meta http-equiv="Content-Type" c>
60 <title>新增留言</title>
61 </head>
62 <body bgcolor="#FFFFFF">
63 <center>
64
65 <br>
66 <form method="POST" action="$scripturl">
67 <input type="hidden" name="action" value="msgadd"></td>
68
69 <table width="90%" >
70 <tr bgcolor="#408080"><td><font color="#FFFFFF">我有話要說</font></td></tr>
71 </table>
72 <br>
73
74 <hr size=1 width="90%">
75 <table cellspacing=0 cellpadding=0 width="90%">
76 <tr>
77 <td>姓名</td>
78 <td><input type="text" name="name" size=48></td>
79 </tr>
80 <tr>
81 <td>留言</td>
82 <td><textarea name="message" rows=10 cols=47></textarea></td>
83 </tr>
84 </table>
85 <hr size=1 width="90%">
86
87 <table cellspacing=0 cellpadding=0 cols=2 width="90%">
88 <tr align=center>
89 <td><input type="submit" name="Submit" VALUE="送出"></td>
90 <td><input type="reset" name="Reset" VALUE="清除"></td>
91 <td><a href="$scripturl">回留言板</a></td>
92 </tr>
93 </table>
94
95 </form>
96
97 </center>
98 </body>
99 </html>
100 |;
101 }
102
103
104
sub msgadd {
105
my ($name, $message)=@_;
106
107 #判斷是否有填 name, message
108 if ( $name eq "" || $message eq "" ) {
109 errormsg("姓名, 留言 欄位都要填, 不可以空白啦");
110 exit(0);
111 }
112
113 if ( $message =~ /< *img *src *=/i ) {
114 errormsg("留言板不可以貼圖喔");
115 exit(0);
116 }
117
118 #把今天的話存入 message 檔....
119
($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =localtime;
120 $msgtime=sprintf("%4d/%02d/%02d %02d:%02d:%02d",$year+1900,$mon+1,$mday,$hour,$min,$sec);
121 $serial=sprintf("%4d%02d%02d%02d%02d%02d",$year+1900,$mon+1,$mday,$hour,$min,$sec);
122 $msgfile="$msgdir/$serial";
123
124 if (defined
$ENV{'HTTP_X_FORWARDED_FOR'}) {
125 $addr=$ENV{'HTTP_X_FORWARDED_FOR'};
126 } else {
127 $addr=$ENV{'REMOTE_ADDR'};
128 }
129
130 open (MSGFILE, ">$msgfile");
131
132 print MSGFILE qq|
133 <a name="$serial"></a>
134 <center>
135 <table cols=1 width="90%" >
136 <tr bgcolor="#408080"><td><i><font color="#FFFFFF">
137 $name 在 $msgtime 從 $addr 留言
138 </font></i></td></tr>
139 <tr><td><pre>$message</pre></td></tr>
140 </table></center>
141 |;
142
143 close(MSGFILE);
144
145 # HTTP HEADER, 回到留言板畫面....
146
print "Location: $scripturl\n\n";
147 }
148
149
150
sub errormsg {
151 my ($msg)=@_;
152
153 # HTTP HEADER
154
print qq|Content-type:text/html\n\n|;
155 # PAGE
156 print qq|
157 <html>
158 <head>
159 <meta http-equiv="Content-Type" c>
160 <title>留言板</title>
161 </head>
162 <body bgcolor=#ffffff>
163 <center>
164 <br>
165 <table width="90%" >
166 <tr bgcolor="#408080"><td><font color="#FFFFFF">留言失敗</font></td></tr>
167 </table>
168
169 <p><hr size=1 width="90%">
170 <p><font color="#CC0000">$msg</font>
171 <p><hr size=1 width="90%">
172
173 <table cols=2 width="90%" ><tr>
174 <td><center><a href="$scripturl?action=msgadd_html">重新留言</a></center></td>
175 <td><center><a href="$scripturl">回留言板</a></center></td>
176 </tr></table>
177
178 </center>
179 </body>
180 </html>
181 |;
182 }
183
184
185
sub catfile {
186 my ($filename)=@_;
187
188 open(F, $filename);
189 while( <F> ) {
190 print "$_";
191 }
192 close(F);
193 }
