« back to all changes in this revision
Viewing changes to edbrowse
- browse files at revision 3
- compare with another revision
- download diff
- download tarball
- view history from revision 3
- Committer: Bazaar Package Importer
- Author(s): Kapil Hari Paranjape
- Date: 2006-10-20 10:47:30 UTC
- mfrom: (1.1.1 upstream)
- Revision ID: james.westby@ubuntu.com-20061020104730-o7vxbrypwaz932dt
Tags: 3.1.2-1
* New upstream version (3.1.2). Closes: #306486.
- programs now written in C
- support for javascript.
* debian/control:
- added Kapil Hari Paranjape to Uploaders.
- Build-depends on "libssl-dev", "libmozjs-dev", "libpcre3-dev".
- Standards-Version to 3.7.2. No changes required.
* debian/rules:
- add "noopt" feature.
- set CFLAGS and LIBS.
- Put $(MAKE) into the build rules.
* debian/copyright: Edited to add the current copyright which
is GPL with the exception for linking with OpenSSL.
* debian/docs: added "README".
* debian/examples: added "jsrt".
- programs now written in C
- support for javascript.
* debian/control:
- added Kapil Hari Paranjape to Uploaders.
- Build-depends on "libssl-dev", "libmozjs-dev", "libpcre3-dev".
- Standards-Version to 3.7.2. No changes required.
* debian/rules:
- add "noopt" feature.
- set CFLAGS and LIBS.
- Put $(MAKE) into the build rules.
* debian/copyright: Edited to add the current copyright which
is GPL with the exception for linking with OpenSSL.
* debian/docs: added "README".
* debian/examples: added "jsrt".
- files added:
- README
- files removed:
- edbrowse
- files modified:
- debian/changelog
added
removed
edbrowse
1
#!/usr/bin/perl
2
3
# edbrowse: line editor/browser
4
5
use IO::Handle;
6
use IO::Socket;
7
use Time::Local;
8
9
=head1 Author
10
11
Karl Dahlke
12
karl@eklhad.net
13
248-524-1004 (during regular business hours)
14
http://www.eklhad.net/linux/app
15
16
=head1 Copyright Notice
17
18
This program is copyright (C) (C) Karl Dahlke, 2000-2003.
19
It is made available, by the author, under the terms of the General Public License (GPL),
20
as articulated by the Free Software Foundation.
21
It may be used for any purpose, and redistributed,
22
provided this copyright notice is included.
23
24
=head1 Redirection
25
26
This program, and its associated documentation, are becoming quite large.
27
Therefore the documentation has been moved to a separate html file.
28
Please visit:
29
30
http://www.eklhad.net/linux/app/edbdoc.html
31
32
If you have lynx on hand, you can run:
33
34
lynx -dump http://www.eklhad.net/linux/app/edbdoc.html > edbdoc.txt
35
36
If you are using lynx to download the actual program, do this:
37
38
lynx -source www.eklhad.net/linux/app/edbrowse >edbrowse
39
40
=cut
41
42
43
$version = "1.5.17";
44
@agents = ("edbrowse/$version");
45
$agent = $agents[0];
46
47
48
# It's tempting to let perl establish the global variables as you go.
49
# Let's try not to do this.
50
# That's where all the side effects are - that's where the bugs come in.
51
# Below are the global variables, with some explanations.
52
53
$debug = 0; # general debugging
54
$errorExit = 0;
55
$ismc = 0; # is mail client
56
$zapmail = 0; # just get rid of the mail
57
$maxfile = 40000000; # Max size of an editable file.
58
$eol = "\r\n"; # end-of-line, as far as http is concerned
59
$doslike = 0; # Is it a Dos-like OS?
60
$doslike = 1 if $^O =~ /^(dos|win|mswin)/i;
61
$errorMsg = ""; # Set this if the last operation produced an error.
62
$inglob = 0; # Are we in global mode, under a g// operation?
63
$onloadSubmit = 0;
64
$inscript = 0; # plowing through javascript
65
$filesize = 0; # size of file just read or written
66
$global_lhs_rhs = 0; # remember lhs and rhs across sessions
67
$caseInsensitive = 0;
68
# Do we send crnl or nl after the lines in a text buffer?
69
# What is the standard - I think it's DOS newlines.
70
$textAreaCR = 1;
71
$pdf_convert = 1; # convert pdf to html
72
$fetchFrames = 1; # fetch the frames into a web page
73
$allsub = 0; # enclose all superscripts and subscripts
74
$allowCookies = 1; # allow all cookies.
75
%cookies = (); # the in-memory cookie jar
76
%authHist = (); # authorization strings by domain
77
$authAttempt = 0; # count authorization attempts for this page
78
$ssl_verify = 1; # By default we verify all certs.
79
$ssl = undef; # ssl connection
80
$ctx = undef; # ssl certificate
81
$allowReferer = 1; # Allow referer header by default.
82
$referer = ""; # refering web page
83
$reroute = 1; # follow http redirections to find the actual web page
84
$rerouteCount = 0; # but prevent infinite loops
85
%didFrame = (); # which frames have we fetched already
86
$passive = 1; # ftp passive mode on by default.
87
$nostack = 0; # suppress stacking of edit sessions
88
$last_z = 1; # line count for the z command
89
$endmarks = 0; # do we print ^ $ at the start and end of lines?
90
$subprint = 0; # print lines after substitutions?
91
$delprint = 0; # print line after delete
92
$dw = 0; # directory write enabled
93
$altattach = 0; # attachments are really alternative presentations of the same email
94
$do_input = 0; # waiting for the next input from the tty
95
$intFlag = 0; # control c was hit
96
$intMsg = "operation interrupted";
97
98
# Interrupt handler, for control C.
99
# Close file handle if we were reading from disk or socket.
100
sub intHandler()
101
{
102
$intFlag = 1;
103
if($do_input) {
104
print "\ninterrupt, type qt to quit completely\n";
105
return;
106
}
107
# Reading from an http server.
108
close FH if defined FH;
109
# Kill ftp data connection if open.
110
close FDFH if defined FDFH;
111
# and mail connection or ftp control connection
112
close SERVER_FH if defined SERVER_FH;
113
# And listening ftp socket.
114
close FLFH if defined FLFH;
115
exit 1 if $ismc;
116
} # intHandler
117
118
$SIG{INT} = \&intHandler;
119
120
# A quieter form of die, without the edbrowse line number, which just confuses people.
121
sub dieq($)
122
{
123
my $msg = shift;
124
print "fatal: $msg\n";
125
exit 1;
126
} # dieq
127
128
@weekDaysShort = ("Sun","Mon","Tue","Wed","Thu","Fri","Sat");
129
@monthsShort = ("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec");
130
sub mailTimeString()
131
{
132
my ($ss, $nn, $hh, $dd, $mm, $yy, $wd) = localtime time;
133
my $wds = $weekDaysShort[$wd];
134
my $mths = $monthsShort[$mm];
135
return sprintf "%s, %02d %s %d %02d:%02d:%02d",
136
$wds, $dd, $mths, $yy+1900, $hh, $nn, $ss;
137
} # mailTimeString
138
139
# ubackup is set when the command has changed something.
140
# The previous text, stored in the save_* variables,
141
# is copied into the last* variables. If you type u,
142
# the last* variables and current variables are swapped.
143
$ubackup = 0;
144
145
# Did we successfully read the edbrowse config file?
146
# If so, set some variables.
147
$myname = $annoyFile = $junkFile = $addressFile = "";
148
%adbook = ();
149
$adbooktime = 0;
150
@inmailserver = (); # list of pop3 servers
151
$mailDir = "";
152
$localMail = -1;
153
$whichMail = 0; # which account to use
154
$smMail = "";
155
$naccounts = 0; # number of pop accounts
156
$outmailserver = ""; # smtp
157
$smtplogin = ""; # smtp login
158
my $mailToSend = "";
159
@pop3login = ();
160
@pop3password = ();
161
@replyAddress = ();
162
@fromSource = ();
163
@fromDest = ();
164
$serverLine = ""; # line received from mail or ftp server
165
166
# web express configuration variables and arrays.
167
%shortcut = ();
168
%commandList = ();
169
%commandCheck = ();
170
$currentShortcut = "";
171
$currentCommandList = "";
172
173
# Specify the start and end of a range for an operation.
174
# 1,3m5 will set these variables to 1, 3, and 5.
175
$startRange = $endRange = $dest = 0;
176
177
# The input command, but only the one-letter commands.
178
$icmd = "";
179
# Now the command that is actually executed is in $cmd.
180
# This is usually the same as $icmd, but not always.
181
# 8i becomes 7a, for instance.
182
$cmd = "";
183
# The valid edbrowse commands.
184
$valid_cmd = "aAbBcdefghHiIjJklmnpqrsStuvwz=^@<";
185
# Commands that can be done in browse mode.
186
$browse_cmd = "AbBdefghHIjJklmnpqsuvwz=^@<";
187
# Commands for directory mode.
188
$dir_cmd = "AbdefghHklnpqsvwz=^@<";
189
# Commands that work at line number 0, in an empty file.
190
$zero_cmd = "aAbefhHqruw=^@<";
191
# Commands that expect a space afterward.
192
$spaceplus_cmd = "befrw";
193
# Commands that should have no text after them.
194
$nofollow_cmd = "aAcdhHijlmnptu=";
195
# Commands that can be done after a g// global directive.
196
$global_cmd = "dIjJlmnpst";
197
# Show the error message, not just the question mark, after these commands.
198
$showerror_cmd = "Abefqrw^@";
199
$helpall = 0; # show the error message all the time
200
201
# Remember that two successive q's will quit the session without changes.
202
# here we must track which session, by number, you were trying to quit.
203
$lastq = $lastqq = -1;
204
205
# For any variable x, there are usually multiple copies of x, one per session.
206
# These are housed in an array @x.
207
# In contrast, the variable $x holds $x[$context],
208
# according to the current context.
209
# I hope this isn't too confusing.
210
$context = 0;
211
212
# dot and dol, current and last line numbers.
213
@dot = (0);
214
$dot = $dot[0];
215
@dol = (0);
216
$dol = $dol[0];
217
@factive = (1); # which sessions are active
218
# Retain file names, and whether the text has been modified.
219
@fname = ("");
220
$fname = $fname[0];
221
$baseref = ""; # usually the same as $fname
222
@fmode = (0); # file modes
223
$fmode = $fmode[0];
224
$binmode = 1; # binary file
225
$nlmode = 2; # newline apended
226
$browsemode = 4; # browsing html text
227
$changemode = 8; # something has changed in this file
228
$dirmode = 16; # directory mode
229
$firstopmode = 32; # first operation issued - undo is possible
230
$nobrowse = "not in browse mode"; # common error message
231
$nixbrowse = "command not available in browse mode";
232
$nixdir = "command not available in directory mode";
233
234
sub dirBrowseCheck($)
235
{
236
my $cmd = shift;
237
$fmode&$browsemode and $errorMsg = "$cmd $nixbrowse", $inglob = 0, return 0;
238
$fmode&$dirmode and $errorMsg = "$cmd $nixdir", $inglob = 0, return 0;
239
return 1;
240
} # dirBrowseCheck
241
242
# retain base directory name when scanning a directory
243
@dirname = ("");
244
$dirname = $dirname[0];
245
246
# Remember substitution strings.
247
@savelhs = (); # save left hand side
248
$savelhs = $savelhs[0];
249
@saverhs = (); # save right hand side
250
$saverhs = $saverhs[0];
251
252
# month hash, to encode dates.
253
%monhash =
254
(jan => 1, feb => 2, mar => 3, apr => 4, may => 5, jun => 6,
255
jul => 7, aug => 8, sep => 9, oct => 10, nov => 11, dec => 12);
256
257
$home = $ENV{HOME};
258
defined $home and length $home or
259
dieq 'home directory not defined by $HOME.';
260
-d $home or
261
dieq "$home is not a directory.";
262
263
# Establish the recycle bin, for deleted files.
264
$rbin = "$home/.recycle";
265
if(! -d $rbin) {
266
$rbin = "" unless mkdir $rbin, 0700;
267
}
268
# Config file for this browser.
269
# Sample file is available at http://www.eklhad.net/linux/app/sample.ebrc
270
$rcFile = "$home/.ebrc";
271
# Last http header, normally deleted before you read the web page.
272
$ebhttp = "$rbin/eb.http";
273
truncate $ebhttp, 0;
274
# When we need a temp file.
275
$ebtmp = "$rbin/eb.tmp";
276
# A file containing SSL certificates in PEM format, concatinated together.
277
# This will be used for certificate verification.
278
$ebcerts = "$home/.ssl-certs";
279
# file for persistant cookies.
280
$ebcooks = "$home/.cookies";
281
sub fillJar() ;
282
fillJar(); # fill up that cooky jar
283
284
# Let's see if we can read the config file?
285
if(open FH, $rcFile) {
286
my $sort = 0;
287
while(<FH>) {
288
s/^\s+//;
289
s/^#.*$//;
290
next if /^$/;
291
s/\s+$//;
292
my ($server, $login, $passwd, $retpath, $key, $value);
293
if(/^([^:\s]+)\s*:\s*([^:\s]+)\s*:\s*([^:\s]+)\s*:\s*([^:\s]+)\s*:\s*([^:\s]*)/) {
294
($server, $login, $passwd, $retpath) = ($1, $2, $3, $4);
295
my $smtpbox = $5;
296
if($server =~ s/^\*\s*//) {
297
dieq "multiple accounts are marked as local, with a star." if $localMail >= 0;
298
$localMail = $naccounts;
299
$smtpbox = $server unless length $smtpbox;
300
$outmailserver = $smtpbox;
301
$smtplogin = $login;
302
}
303
$inmailserver[$naccounts] = $server;
304
$pop3login[$naccounts] = $login;
305
$pop3password[$naccounts] = $passwd;
306
$replyAddress[$naccounts] = $retpath;
307
++$naccounts;
308
next;
309
} # describing a mail server
310
311
# Now look form keyword = string.
312
# Initial < is shorthand for cmd =
313
s/^\</cmd =/;
314
if(/^([^=]+)=\s*(.+)/) {
315
$key = $1;
316
$value = $2;
317
$key =~ s/\s+$//;
318
$myname = $value, next if $key eq "fullname";
319
$addressFile = $value, next if $key eq "addressbook";
320
$junkFile = $value, next if $key eq "junkfile";
321
$annoyFile = $value, next if $key eq "annoyfile";
322
$mailDir = $value, next if $key eq "cd";
323
324
if($key eq "from") {
325
if($value =~ /^\s*([^\s>]+)\s*>\s*(.+)$/) {
326
push @fromSource, lc $1;
327
push @fromDest, $2;
328
next;
329
}
330
dieq "from filter \"$value\" does not look like \"emailAddress > file\".";
331
} # from
332
333
if($key eq "agent") {
334
push @agents, $value;
335
next;
336
} # agent
337
338
# web express keywords
339
if($key eq "shortcut") {
340
if(length $currentShortcut and ! defined $shortcut{$currentShortcut}{url}) {
341
dieq "shortcut $currentShortcut has not been assigned a url";
342
}
343
$value =~ /^[\w-]+$/ or dieq "the name of a shortcut must consist of letters digits or dashes, $value is invalid";
344
$currentShortcut = $value;
345
# Start out with no post processing commands.
346
$shortcut{$value}{after} = [];
347
$shortcut{$value}{sort} = sprintf "%04d", $sort;
348
++$sort;
349
$currentCommandList = "";
350
next;
351
} # shortcut
352
if($key eq "cmdlist") {
353
if(length $currentShortcut and ! defined $shortcut{$currentShortcut}{url}) {
354
dieq "shortcut $currentShortcut has not been assigned a url";
355
}
356
$currentShortcut = "";
357
my $check = 0;
358
$check = 1 if $value =~ s/^\+//;
359
$value =~ /^[\w-]+$/ or dieq "the name of a command list must consist of letters digits or dashes, $value is invalid.";
360
$currentCommandList = $value;
361
$commandList{$value} = [];
362
$commandCheck{$value} = $check;
363
next;
364
} # cmdlist
365
if($key eq "cmd") {
366
length $currentShortcut or length $currentCommandList or
367
dieq "postprocessing command is not part of a command list or shortcut";
368
my $cref; # command reference
369
$cref = $shortcut{$currentShortcut}{after} if length $currentShortcut;
370
$cref = $commandList{$currentCommandList} if length $currentCommandList;
371
# is this a command list?
372
if($value =~ /^[a-zA-Z_-]+$/ and defined $commandList{$value}) {
373
my $cpush = $commandList{$value};
374
push @$cref, @$cpush;
375
} else {
376
push @$cref, $value;
377
}
378
next;
379
} # cmd
380
if($key eq "url") {
381
length $currentShortcut or dieq "$key command without a current shortcut";
382
$shortcut{$currentShortcut}{url} = $value;
383
next;
384
} # url
385
if($key eq "desc") {
386
length $currentShortcut or dieq "$key command without a current shortcut";
387
$shortcut{$currentShortcut}{desc} = $value;
388
next;
389
} # desc
390
391
dieq "Unrecognized keyword <$key> in config file.";
392
}
393
394
dieq "garbled line <$_> in config file.";
395
} # loop over lines in config file
396
close FH;
397
398
if(length $currentShortcut and ! defined $shortcut{$currentShortcut}{url}) {
399
dieq "shortcut $currentShortcut has not been assigned a url";
400
}
401
402
if($naccounts) {
403
$localMail = 0 if $naccounts == 1;
404
dieq "None of the pop3 accounts is marked as local." if $localMail < 0;
405
dieq "fullname not specified in the config file." if ! length $myname;
406
} # mail accounts
407
} # open succeeded
408
409
# One array holds all the lines of text (without the newlines)
410
# for all the files in all the sessions.
411
# Within a given session, the actual file is represented by a list of numbers,
412
# indexes into this large array.
413
# Note that when text is copied, we actually copy the strings in the array.
414
# I could just have different lines use the same index, thus pointing to the
415
# same string, and there would be no need to copy that string,
416
# but then I'd have to maintain reference counts on all these strings,
417
# and that would make the program very messy!
418
@text = ();
419
420
# If a file has 30 lines, it is represented by 30 numbers,
421
# indexes into @text above.
422
# Should we use an array of numbers, or a string of numbers
423
# represented by decimal digits?
424
# Both are painful, in different ways.
425
# Consider inserting a block of text, a very common operation.
426
# In a list, we would have to slide all the following numbers down.
427
# Granted, that's better than copying all those lines of text down,
428
# but it's still a pain to program, and somewhat inefficient.
429
# If we use strings, we take the original string of numbers,
430
# break it at the insert point, and make a new string
431
# by concatenating these two pieces with the new block.
432
# The same issues arise when deleting text near the top of a file.
433
# This and other considerations push me towards strings.
434
# I currently use 6 characters for a line number, and a seventh for the g// flag.
435
$lnwidth = 7; # width of a line number field in $map
436
$lnwidth1 = $lnwidth - 1;
437
$lnformat = "%6d ";
438
$lnspace = ' ' x $lnwidth;
439
$lnmax = 999999;
440
# Note that line 0 never maps to anything in @text.
441
@map = ($lnspace);
442
$map = $map[0];
443
# The 26 labels, corresponding to the lower case letters.
444
# These are stored in a packed string, like $map above.
445
# labels also holds the filetype suffixes when in directory mode.
446
@labels = ($lnspace x 26);
447
$labels = $labels[0];
448
# offset into $labels, where directory suffixes begin.
449
$dirSufStart = 26 * $lnwidth;
450
451
# The anchor/form/input tags, for browsing.
452
# The browse tags are in an array of hashes.
453
# Each hash has tag=tagname,
454
# and attrib=value for each attrib=value in the tag.
455
# Be advised that certain special tags, such as those defining
456
# title and description and keywords, are placed in btag[0].
457
@btags = ();
458
$btags = $btags[0];
459
460
# When we focus on an input field, for edit or manipulation,
461
# we need its type, size, and list of options.
462
$inf = ""; # current text displayed by this input field.
463
$itype = ""; # Type of the input field.
464
$isize = 0; # size of the input field.
465
$iopt = {}; # hash of input options in a discrete list.
466
$irows = $icols = 0; # for a text area window.
467
$iwrap = ""; # Can we scroll beyond this window?
468
$itag = undef; # the input tag from which the previous variables were derived.
469
$iline = 0; # line where this input field was found.
470
$ifield = 0; # field number, within the line, the nth input field on the line.
471
$itagnum = 0; # tag number for this input field.
472
$inorange = "this input directive cannot be applied to a range of lines";
473
$inoglobal = "this input directive cannot be applied globally";
474
475
# last* and save* variables mirror the variables that define your session.
476
# This supports the undo command.
477
$lastdot = $savedot = $lastdol = $savedol = 0;
478
$lastmap = $savemap = $lastlabels = $savelabels = "";
479
480
# Variables to format text, i.e. break lines at sentence/phrase boundaries.
481
$refbuf = ""; # The new, reformatted buffer.
482
$lineno = $colno = 0; # line/column number
483
$optimalLine = 80; # optimal line length
484
$cutLineAfter = 36; # cut sentence or phrase after this column
485
$paraLine = 120; # longer lines are assumed to be self-contained paragraphs
486
$longcut = 0; # last cut of a long line
487
$lspace = 3; # last space value, 3 = paragraph
488
$lperiod = $lcomma = $lright = $lany = 0; # columns for various punctuations
489
$idxperiod = $idxcomma = $idxright = $idxany = 0;
490
491
# Push the entire edit session onto a stack, for the back key.
492
# A hash will hold all the variables that make a session,
493
# such as $map, $fname, $btags, etc.
494
@backup = ();
495
$backup = $backup[0];
496
497
$hexChars = "0123456789abcdefABCDEF";
498
499
# Valid delimiters for search/substitute.
500
# note that \ is conspicuously absent, not a valid delimiter.
501
# I alsso avoid nestable delimiters such as parentheses.
502
# And no alphanumerics please -- too confusing.
503
$valid_delim = "-_=!|#*;:`\"',./?+@";
504
505
# $linePending holds a line of text that you accidentally typed in
506
# while edbrowse was in command mode.
507
# When you see the question mark, immediately type a+ to recover the line.
508
$linePending = undef;
509
510
511
# That's it for the globals, here comes the code.
512
# First a few support routines.
513
# Strip white space from either side.
514
sub stripWhite($)
515
{
516
my $line = shift;
517
$$line =~ s/^\s+//;
518
$$line =~ s/\s+$//;
519
} # stripWhite
520
521
# Is a filename a URL?
522
# If it is, return the transport protocol, e.g. http.
523
sub is_url($)
524
{
525
my $line = shift;
526
return 'http' if $line =~ m,^http://[^\s],i;
527
return 'https' if $line =~ m,^https://[^\s],i;
528
return 'gopher' if $line =~ m,^gopher://[^\s],i;
529
return 'telnet' if $line =~ m,^telnet://[^\s],i;
530
return 'ftp' if $line =~ m,^ftp://[^\s],i;
531
# I assume that the following will be regular http.
532
# Strip off the ?this=that stuff
533
$line =~ s:\?.*::;
534
# Strip off the file name and .browse suffix.
535
$line =~ s:/.*::;
536
$line =~ s/\.browse$//;
537
$line =~ s/:\d+$//;
538
return 0 if $line !~ /\w\.\w.*\w\.\w/; # we need at least two internal dots
539
# Look for an ip address, four numbers and three dots.
540
return 'http' if $line =~ /^\d+\.\d+\.\d+\.\d+$/;
541
$line =~ s/.*\.//;
542
return 'http' if index(".com.biz.info.net.org.gov.edu.us.uk.au.ca.de.jp.be.nz.sg.", ".$line.") >= 0;
543
} # is_url
544
545
# Apply a (possibly) relative path to a preexisting url.
546
# The new url is returned.
547
# resolveUrl("http://www.eklhad.net/linux/index.html", "app") returns
548
# "http://www.eklhad.net/linux/app"
549
sub resolveUrl($$)
550
{
551
my ($line, $href) = @_;
552
my $scheme;
553
$line = "" unless defined $line;
554
$line =~ s/\.browse$//;
555
# debug print - this is a very subtle routine.
556
print "resolve($line, $href)\n" if $debug >= 2;
557
# Some people, or generators, actually write http://../whatever.html
558
$href =~ s/^http:(\.+)/$1/i;
559
$href =~ s,^http://(\.*/),$1,i;
560
return $href unless length $href and length $line and ! is_url($href);
561
if(substr($href, 0, 1) ne '/') {
562
$line =~ s/\?.*//; # hope this is right
563
if(substr($href, 0, 1) ne '?') {
564
if($line =~ s,^/[^/]*$,, or
565
$line =~ s,([^/])/[^/]*$,$1,) {
566
# We stripped off the last directory
567
$line .= '/';
568
} else {
569
if($scheme = is_url $line) {
570
$line .= '/';
571
} else {
572
$line = "";
573
}
574
} # stripping off last directory
575
} # doesn't start with ?
576
} elsif($scheme = is_url $line) {
577
# Keep the scheme and server, lose the filename
578
$line =~ s/\?.*//; # hope this is right
579
$line =~ s,^($scheme://[^/]*)/.*,$1,i;
580
} else {
581
$line = "";
582
}
583
return $line.$href;
584
} # resolveUrl
585
586
# Prepare a string for http transmition.
587
# No, I really don't know which characters to encode.
588
# I'm probably encoding more than I need to -- hope that's ok.
589
sub urlEncode($)
590
{
591
$_ = shift;
592
s/([^-\w .@])/sprintf('%%%02X',ord($1))/ge;
593
y/ /+/;
594
return $_;
595
} # urlEncode
596
597
sub urlDecode($)
598
{
599
$_ = shift;
600
y/+/ /;
601
s/%([0-9a-fA-F]{2})/chr hex "$1"/ge;
602
return $_;
603
} # urlDecode
604
605
# Pull the subject out of a sendmail url.
606
sub urlSubject($)
607
{
608
my $href = shift;
609
if($$href =~ s/\?(.*)$//) {
610
my @pieces = split '&', $1;
611
foreach my $j (@pieces) {
612
next unless $j =~ s/^subject=//i;
613
my $subj = urlDecode $j;
614
stripWhite \$subj;
615
return $subj;
616
} # loop
617
} # attributes after the email
618
return "";
619
} # urlSubject
620
621
# Get raw text ready for html display.
622
sub textUnmeta($)
623
{
624
my $tbuf = shift;
625
return unless length $$tbuf;
626
$$tbuf =~ s/&/&/g;
627
$$tbuf =~ s/</</g;
628
$$tbuf =~ s/>/>/g;
629
$$tbuf =~ s/^/<P><PRE>/;
630
$$tbuf =~ s/$/<\/PRE><P>\n/;
631
} # textUnmeta
632
633
# Derive the alt description for an image or hyperlink.
634
sub deriveAlt($$)
635
{
636
my $h = shift;
637
my $href = shift;
638
my $alt = $$h{alt};
639
$alt = "" unless defined $alt;
640
stripWhite \$alt;
641
# Some alt descriptions are flat-out useless.
642
$alt =~ s/^[^\w]+$//;
643
return $alt if length $alt;
644
if(!length $href) {
645
$href = $$h{href};
646
$href = "" unless defined $href;
647
}
648
$alt = $href;
649
$alt =~ s/^javascript.*$//i;
650
$alt =~ s/^\?//;
651
$alt =~ s:\?.*::s;
652
$alt =~ s:.*/::;
653
$alt =~ s/\.[^.]*$//;
654
$alt =~ s:/$::;
655
return $alt;
656
} # deriveAlt
657
658
# Pull the reference out of a javascript openWindow() call.
659
$foundFunc = "";
660
sub javaWindow($)
661
{
662
my $jc = shift; # java call
663
my $page = "";
664
$foundFunc = "";
665
$page = $1 if $jc =~ /(?:open|location|window)[\w.]* *[(=] *["']([\w._\/:,=@&?+-]+)["']/i;
666
return $page if length $page;
667
return "submit" if $jc =~ /\bsubmit *\(/i;
668
while($jc =~ /(\w+) *\(/g) {
669
my $f = $1;
670
my $href = $$btags[0]{fw}{$f};
671
if($href) {
672
$href =~ s/^\*//;
673
$foundFunc = $f;
674
$page = $href;
675
}
676
}
677
return $page;
678
} # javaWindow
679
680
# Try to find the Java functions
681
sub javaFunctions($)
682
{
683
my $tbuf = shift;
684
my $flc = 0; # function line count
685
my $f; # java function
686
while($$tbuf =~ /(.+)/g) {
687
my $line = $1;
688
if($line =~ /function *(\w+)\(/) {
689
$f = $1;
690
print "java function $f\n" if $debug >= 6;
691
$flc = 1;
692
}
693
my $win = javaWindow $line;
694
if(length $win) {
695
if($flc) {
696
if(not defined $$btags[0]{fw}{$f}) {
697
$$btags[0]{fw}{$f} = "*$win";
698
print "$f: $win\n" if $debug >= 3;
699
}
700
} elsif($win ne "submit") {
701
my $h = {};
702
push @$btags, $h;
703
$attrhidden = hideNumber($#$btags);
704
$$h{ofs1} = length $refbuf;
705
my $alt = deriveAlt($h, $win);
706
$alt = "relocate" unless length $alt;
707
createHyperLink($h, $win, $alt);
708
}
709
}
710
next unless $flc;
711
++$flc;
712
$flc = 0 if $flc == 12;
713
} # loop over lines
714
} # javaFunctions
715
716
# Mixed case.
717
sub mixCase($)
718
{
719
my $w = lc shift;
720
$w =~ s/\b([a-z])/uc $1/ge;
721
# special McDonald code
722
$w =~ s/Mc([a-z])/"Mc".uc $1/ge;
723
return $w;
724
} # mixCase
725
726
# Create a hyperlink where there was none before.
727
sub createHyperLink($$$)
728
{
729
my ($h, $href, $desc) = @_;
730
$$h{tag} = "a";
731
$$h{bref} = $baseref;
732
$$h{href} = $href;
733
$refbuf .= "\x80$attrhidden" . "{$desc}";
734
$colno += 2 + length $desc;
735
$$h{ofs2} = length $refbuf;
736
$lspace = 0;
737
} # createHyperLink
738
739
# meta html characters.
740
# There's lots more -- this is just a starter.
741
%charmap = (
742
# Normal ascii symbols
743
gt => '>', lt => '<', quot => '"',
744
plus => '+', minus => '-', colon => ':',
745
apos => '`', star => '*', comma => ',',
746
period => '.', dot => ".",
747
dollar => '$', percnt => '%', amp => '&',
748
# International letters
749
ntilde => "\xf1", Ntilde => "\xd1",
750
agrave => "\xe0", Agrave => "\xc0",
751
egrave => "\xe8", Egrave => "\xc8",
752
igrave => "\xec", Igrave => "\xcc",
753
ograve => "\xf2", Ograve => "\xd2",
754
ugrave => "\xf9", Ugrave => "\xd9",
755
auml => "\xe4", Auml => "\xc4",
756
euml => "\xeb", Euml => "\xcb",
757
iuml => "\xef", Iuml => "\xcf",
758
ouml => "\xf6", Ouml => "\xd6",
759
uuml => "\xfc", Uuml => "\xdc",
760
yuml => "\xff", Yuml => 'Y',
761
aacute => "\xe1", Aacute => "\xc1",
762
eacute => "\xe9", Eacute => "\xc9",
763
iacute => "\xed", Iacute => "\xcd",
764
oacute => "\xf3", Oacute => "\xd3",
765
uacute => "\xfa", Uacute => "\xda",
766
yacute => "\xfd", Yacute => "\xdd",
767
atilde => "\xe3", Atilde => "\xc3",
768
itilde => 'i', Itilde => 'I',
769
otilde => "\xf5", Otilde => "\xd5",
770
utilde => 'u', Utilde => 'U',
771
acirc => "\xe2", Acirc => "\xc2",
772
ecirc => "\xea", Ecirc => "\xca",
773
icirc => "\xee", Icirc => "\xce",
774
ocirc => "\xf4", Ocirc => "\xd4",
775
ucirc => "\xfb", Ucirc => "\xdb",
776
# Other 8-bit symbols.
777
# I turn these into their 8 bit equivalents,
778
# then a follow-on routine turns them into words for easy reading.
779
# Some speech adapters do this as well, saying "cents" for the cents sign,
780
# but yours may not, so I do some of these translations for you.
781
# But not here, because some people put the 8-bit cents sign in directly,
782
# rather then ¢, so I've got to do that translation later.
783
pound => "\xa3", cent => "\xa2",
784
sdot => "\xb7",
785
middot => "\xb7",
786
edot => 'e',
787
nbsp => ' ',
788
times => "\xd7",
789
divide => "\xf7",
790
deg => "\xb0",
791
frac14 => "\xbc",
792
half => "\xbd",
793
frac34 => "\xbe",
794
frac13 => "1/3",
795
frac23 => "2/3",
796
copy => "\xa9",
797
reg => "\xae",
798
trade => "(TM)",
799
);
800
801
%symbolmap = (
802
a => "945",
803
b => "946",
804
g => "947",
805
d => "948",
806
e => "949",
807
z => "950",
808
h => "951",
809
q => "952",
810
i => "953",
811
k => "954",
812
l => "955",
813
m => "956",
814
n => "957",
815
x => "958",
816
o => "959",
817
p => "960",
818
r => "961",
819
s => "963",
820
t => "964",
821
u => "965",
822
f => "966",
823
c => "967",
824
y => "968",
825
w => "969",
826
177 => "8177", # kludge!! I made up 8177
827
198 => "8709",
828
219 => "8660",
829
209 => "8711",
830
229 => "8721",
831
206 => "8712",
832
207 => "8713",
833
242 => "8747",
834
192 => "8501",
835
172 => "8592",
836
174 => "8594",
837
165 => "8734",
838
199 => "8745",
839
200 => "8746",
840
64 => "8773",
841
182 => "8706",
842
185 => "8800",
843
162 => "8242",
844
163 => "8804",
845
179 => "8805",
846
204 => "8834",
847
205 => "8838",
848
201 => "8835",
849
203 => "8836",
850
202 => "8839",
851
208 => "8736",
852
);
853
854
# map certain font=symbol characters to words
855
%symbolWord = (
856
176 => "degrees",
857
188 => "1fourth",
858
189 => "1half",
859
190 => "3fourths",
860
215 => "times",
861
247 => "divided by",
862
913 => "Alpha",
863
914 => "Beta",
864
915 => "Gamma",
865
916 => "Delta",
866
917 => "Epsilon",
867
918 => "Zeta",
868
919 => "Eta",
869
920 => "Theta",
870
921 => "Iota",
871
922 => "Kappa",
872
923 => "Lambda",
873
924 => "Mu",
874
925 => "Nu",
875
926 => "Xi",
876
927 => "Omicron",
877
928 => "Pi",
878
929 => "Rho",
879
931 => "Sigma",
880
932 => "Tau",
881
933 => "Upsilon",
882
934 => "Phi",
883
935 => "Chi",
884
936 => "Psi",
885
937 => "Omega",
886
945 => "alpha",
887
946 => "beta",
888
947 => "gamma",
889
948 => "delta",
890
949 => "epsilon",
891
950 => "zeta",
892
951 => "eta",
893
952 => "theta",
894
953 => "iota",
895
954 => "kappa",
896
955 => "lambda",
897
956 => "mu",
898
957 => "nu",
899
958 => "xi",
900
959 => "omicron",
901
960 => "pi",
902
961 => "rho",
903
962 => "sigmaf",
904
963 => "sigma",
905
964 => "tau",
906
965 => "upsilon",
907
966 => "phi",
908
967 => "chi",
909
968 => "psi",
910
969 => "omega",
911
8177 => "+-", # kludge!! I made up 8177
912
8242 => "prime",
913
8501 => "aleph",
914
8592 => "left arrow",
915
8594 => "arrow",
916
8660 => "double arrow",
917
8706 => "d",
918
8709 => "empty set",
919
8711 => "del",
920
8712 => "member of",
921
8713 => "not a member of",
922
8721 => "sum",
923
8734 => "infinity",
924
8736 => "angle",
925
8745 => "intersect",
926
8746 => "union",
927
8747 => "integral",
928
8773 => "congruent to",
929
8800 => "not equal",
930
8804 => "less equal",
931
8805 => "greater equal",
932
8834 => "proper subset of",
933
8835 => "proper superset of",
934
8836 => "not a subset of",
935
8838 => "subset of",
936
8839 => "superset of",
937
);
938
939
# Map an html meta character using the above hashes.
940
# Usually run from within a global substitute.
941
sub metaChar($)
942
{
943
my $meta = shift;
944
if($meta =~ /^#(\d+)$/) {
945
return chr $1 if $1 <= 255;
946
return "'" if $1 == 8217;
947
return "\x82$1#" if $symbolWord{$1};
948
return "?";
949
}
950
my $real = $charmap{$meta};
951
defined $real or $real = "?";
952
return $real;
953
} # metaChar
954
955
# Translate <font face=symbol>number</font>.
956
# This is highly specific to my web pages - doesn't work in general!
957
sub metaSymbol($)
958
{
959
my $meta = shift;
960
$meta =~ s/^&#//;
961
$meta =~ s/;$//;
962
my $real = $symbolmap{$meta};
963
return "?" unless $real;
964
return "&#$real;";
965
} # metaSymbol
966
967
# replace VAR with $VAR, as defined by the environment.
968
sub envVar($)
969
{
970
my $var = shift;
971
my $newvar = $ENV{$var};
972
if(defined $newvar) {
973
# There shouldn't be any whitespace at the front or back.
974
stripWhite \$newvar;
975
return $newvar if length $newvar;
976
}
977
length $errorMsg or
978
$errorMsg = "environment variable $var not set";
979
return "";
980
} # envVar
981
982
# Replace the variables in a line, using the above.
983
sub envLine($)
984
{
985
my $line = shift;
986
$errorMsg = "";
987
# $errorMsg will be set if something goes wrong.
988
$line =~ s,^~/,\$HOME/,;
989
$line =~ s/\$([a-zA-Z]\w*)/envVar($1)/ge;
990
return $line;
991
} # envLine
992
993
# The filename can be specified using environment variables,
994
# and shell meta characters such as *.
995
# But not if it's a url.
996
sub envFile($)
997
{
998
my $filename = shift;
999
$errorMsg = "";
1000
if(! is_url($filename)) {
1001
$filename = envLine($filename);
1002
return if length $errorMsg;
1003
my @filelist;
1004
# This is real kludgy - I just don't understand how glob works.
1005
if($filename =~ / / and $filename !~ /"/) {
1006
@filelist = glob '"'.$filename.'"';
1007
} else {
1008
@filelist = glob $filename;
1009
}
1010
$filelist[0] = $filename if $#filelist < 0;
1011
$errorMsg = "wild card expansion produces multiple files" if $#filelist;
1012
$filename = $filelist[0];
1013
}
1014
return $filename;
1015
} # envFile
1016
1017
# Drop any active edit sessions that have no text, and no associated file.
1018
# This housecleaning routine is run on every quit or backup command.
1019
sub dropEmptyBuffers()
1020
{
1021
foreach my $cx (0..$#factive) {
1022
next if $cx == $context;
1023
next unless $factive[$cx];
1024
next if length $fname[$cx];
1025
next if $dol[$cx];
1026
$factive[$cx] = undef;
1027
}
1028
} # dropEmptyBuffers
1029
1030
# Several small functions to switch between contexts, i.e. editing sessions.
1031
# In all these functions, we have to map between our context numbers,
1032
# that start with 0, and the user's session numbers, that start with 1.
1033
# C and fortran programmers will be use to this problem.
1034
# Is a context different from the currently running context?
1035
sub cxCompare($)
1036
{
1037
my $cx = shift;
1038
$errorMsg = "session 0 is invalid", return 0 if $cx < 0;
1039
return 1 if $cx != $context; # ok
1040
++$cx;
1041
$errorMsg = "you are already in session $cx";
1042
return 0;
1043
} # cxCompare
1044
1045
# Is a context active?
1046
sub cxActive($)
1047
{
1048
my $cx = shift;
1049
return 1 if $factive[$cx];
1050
++$cx;
1051
$errorMsg = "session $cx is not active";
1052
return 0;
1053
} # cxActive
1054
1055
# Switch to another editing session.
1056
# This assumes cxCompare has succeeded - we're moving to a different context.
1057
# Pass the context number and an interactive flag.
1058
sub cxSwitch($$)
1059
{
1060
my ($cx, $ia) = @_;
1061
# Put the variables in a known start state if this is a virgin session.
1062
cxReset($cx, 0) if ! defined $factive[$cx];
1063
$dot[$context] = $dot, $dot = $dot[$cx];
1064
$dol[$context] = $dol, $dol = $dol[$cx];
1065
$fname[$context] = $fname, $fname = $fname[$cx];
1066
$dirname[$context] = $dirname, $dirname = $dirname[$cx];
1067
$map[$context] = $map, $map = $map[$cx];
1068
$labels[$context] = $labels, $labels = $labels[$cx];
1069
$btags = $btags[$cx];
1070
$backup[$context] = $backup, $backup = $backup[$cx];
1071
if(!$global_lhs_rhs) {
1072
$savelhs[$context] = $savelhs, $savelhs = $savelhs[$cx];
1073
$saverhs[$context] = $saverhs, $saverhs = $saverhs[$cx];
1074
}
1075
$fmode[$context] = $fmode, $fmode = $fmode[$cx];
1076
# But we don't replicate the last* variables per context,
1077
# so your ability to undo is destroyed if you switch contexts.
1078
$fmode &= ~$firstopmode;
1079
if($ia) {
1080
if(defined $factive[$cx]) {
1081
print ((length($fname[$cx]) ? $fname[$cx] : "no file")."\n");
1082
} else {
1083
print "new session\n";
1084
}
1085
}
1086
$factive[$cx] = 1;
1087
$context = $cx;
1088
return 1;
1089
} # cxSwitch
1090
1091
# Can we trash the data in a context?
1092
# If so, trash it, and reset all the variables.
1093
# The second parameter is a close directive.
1094
# If nonzero, we clear out empty buffers associated with
1095
# text areas in the fill-out forms (browse mode).
1096
# A value of 1, as opposed to 2, means close down the entire session.
1097
sub cxReset($$)
1098
{
1099
my ($cx, $close) = @_;
1100
1101
if(defined $factive[$cx]) {
1102
# We might be trashing data, make sure that's ok.
1103
$fname[$cx] = $fname, $fmode[$cx] = $fmode if $cx == $context;
1104
if($fmode[$cx]&$changemode and
1105
!( $fmode[$cx]&$dirmode) and
1106
$lastq != $cx and
1107
length $fname[$cx] and
1108
! is_url($fname[$cx])) {
1109
$errorMsg = "expecting `w'";
1110
$lastqq = $cx;
1111
if($cx != $context) {
1112
++$cx;
1113
$errorMsg .= " on session $cx";
1114
}
1115
return 0;
1116
} # warning message
1117
1118
if($close) {
1119
dropEmptyBuffers();
1120
if($close&1) {
1121
# And we're closing this session.
1122
$factive[$cx] = undef;
1123
$backup[$cx] = undef;
1124
}
1125
}
1126
} # session was active
1127
1128
# reset the variables
1129
$dot[$cx] = $dol[$cx] = 0;
1130
$map[$cx] = $lnspace;
1131
$fname[$cx] = "";
1132
$dirname[$cx] = "";
1133
$labels[$cx] = $lnspace x 26;
1134
$btags[$cx] = [];
1135
$savelhs[$cx] = $saverhs[$cx] = undef;
1136
$fmode[$cx] = 0;
1137
if($cx == $context) {
1138
$dot = $dol = 0;
1139
$map = $map[$cx];
1140
$fname = "";
1141
$labels = $labels[$cx];
1142
$btags = $btags[$cx];
1143
$global_lhs_rhs or $savelhs = $saverhs = undef;
1144
$fmode = 0;
1145
} # current context
1146
1147
return 1;
1148
} # cxReset
1149
1150
# Pack all the information about the current context into a hash.
1151
# This will be pushed onto a virtual stack.
1152
# When you enter the back key, it all gets unpacked again,
1153
# to restore your session.
1154
sub cxPack()
1155
{
1156
my $h = {
1157
dot =>$dot, dol => $dol, map => $map, labels => $labels,
1158
lastdot =>$lastdot, lastdol => $lastdol, lastmap => $lastmap, lastlabels => $lastlabels,
1159
fname => $fname, dirname => $dirname,
1160
fmode => $fmode&~$changemode,
1161
savelhs => $savelhs, saverhs => $saverhs,
1162
btags => $btags,
1163
};
1164
return $h;
1165
} # cxPack
1166
1167
sub cxUnpack($)
1168
{
1169
my $h = shift;
1170
return if ! defined $h;
1171
$dot = $$h{dot};
1172
$lastdot = $$h{lastdot};
1173
$dol = $$h{dol};
1174
$lastdol = $$h{lastdol};
1175
$map = $$h{map};
1176
$lastmap = $$h{lastmap};
1177
$labels = $$h{labels};
1178
$lastlabels = $$h{lastlabels};
1179
$fmode = $$h{fmode};
1180
$fname = $$h{fname};
1181
$dirname = $$h{dirname};
1182
if(!$global_lhs_rhs) {
1183
$savelhs = $$h{savelhs};
1184
$saverhs = $$h{saverhs};
1185
}
1186
$btags[$context] = $btags = $$h{btags};
1187
} # cxUnpack
1188
1189
# find an available session and load it with some initial data.
1190
# Returns the context number.
1191
sub cxCreate($$)
1192
{
1193
my ($text_ptr, $filename) = @_;
1194
# Look for an unused buffer
1195
my ($cx, $j);
1196
for($cx=0; $cx<=$#factive; ++$cx) {
1197
last unless defined $factive[$cx];
1198
}
1199
cxReset($cx, 0);
1200
$factive[$cx] = 1;
1201
$fname[$cx] = $filename;
1202
my $bincount = $$text_ptr =~ y/\0\x80-\xff/\0\x80-\xff/;
1203
if($bincount*4 - 10 < length $$text_ptr) {
1204
# A text file - remove crlf in the dos world.
1205
$$text_ptr =~ s/\r\n/\n/g if $doslike;
1206
} else {
1207
$fmode[$cx] |= $binmode;
1208
}
1209
$fmode[$cx] |= $nlmode unless $$text_ptr =~ s/\n$//;
1210
$j = $#text;
1211
if(length $$text_ptr) {
1212
push @text, split "\n", $$text_ptr, -1;
1213
}
1214
if(!lineLimit(0)) {
1215
my $newpiece = $lnspace;
1216
++$dol[$cx], $newpiece .= sprintf($lnformat, $j) while ++$j <= $#text;
1217
$map[$cx] = $newpiece;
1218
$dot[$cx] = $dol[$cx];
1219
} else {
1220
warn $errorMsg;
1221
}
1222
return $cx;
1223
} # cxCreate
1224
1225
# See if @text is too big.
1226
# Pass the number of lines we will be adding.
1227
sub lineLimit($)
1228
{
1229
my $more = shift;
1230
return 0 if $#text + $more <= $lnmax;
1231
$errorMsg = "Your limit of 1 million lines has been reached.\nSave your files, then exit and restart this program.";
1232
return 1;
1233
} # lineLimit
1234
1235
# Hide and reveal numbers that are internal to the line.
1236
# These numbers indicate links and input fields, and are not displayed by the next routine.
1237
sub hideNumber($)
1238
{
1239
my $n = shift;
1240
$n =~ y/0-9/\x85-\x8f/;
1241
return $n;
1242
} # hideNumber
1243
1244
sub revealNumber($)
1245
{
1246
my $n = shift;
1247
$n =~ y/\x85-\x8f/0-9/;
1248
return $n;
1249
} # revealNumber
1250
1251
sub removeHiddenNumbers($)
1252
{
1253
my $t = shift;
1254
$$t =~ s/\x80[\x85-\x8f]+([<>{])/$1/g;
1255
$$t =~ s/\x80[\x85-\x8f]+\*//g;
1256
} # removeHiddenNumbers
1257
1258
# Small helper function to retrieve the text for line number n.
1259
# If the second parameter is set, hidden numbers are left in place;
1260
# otherwise they are stripped out via removeHiddenNumbers().
1261
sub fetchLine($$)
1262
{
1263
my $n = shift;
1264
my $show = shift;
1265
return "" unless $n; # should never happen
1266
my $t = $text[substr($map, $n*$lnwidth, $lnwidth1)];
1267
removeHiddenNumbers(\$t) if $show and $fmode&$browsemode;
1268
return $t;
1269
} # fetchLine
1270
1271
# Here's the same function, but for another context.
1272
sub fetchLineContext($$$)
1273
{
1274
my $n = shift;
1275
my $show = shift;
1276
my $cx = shift;
1277
$t = $text[substr($map[$cx], $n*$lnwidth, $lnwidth1)];
1278
removeHiddenNumbers(\$t) if $show and $fmode&$browsemode;
1279
return $t;
1280
} # fetchLineContext
1281
1282
# Print size of the text in buffer.
1283
sub apparentSize()
1284
{
1285
my $j = 0;
1286
$j += length(fetchLine($_, 1)) + 1 foreach (1..$dol);
1287
--$j if $fmode&$nlmode;
1288
print "$j\n";
1289
} # apparentSize
1290
1291
# Read a line from stdin.
1292
# Could be a command, could be text going into the buffer.
1293
sub readLine()
1294
{
1295
my ($i, $j, $c, $d, $line);
1296
getline: {
1297
$intFlag = 0;
1298
$do_input = 1;
1299
$line = <STDIN>;
1300
$do_input = 0;
1301
redo getline if $intFlag and ! defined $line; # interrupt
1302
$intFlag = 0;
1303
}
1304
exit 0 unless defined $line; # EOF
1305
$line =~ s/\n$//;
1306
# A bug in my keyboard causes nulls to be entered from time to time.
1307
$line =~ s/\0/ /g;
1308
return $line if $line !~ /~/; # shortcut
1309
# We have to process it, character by character.
1310
my $line2 = "";
1311
for($i=0; $i<length($line); $line2 .= $c, ++$i) {
1312
$c = substr $line, $i, 1;
1313
next if $c ne '~';
1314
next if $i == length($line) - 1;
1315
$d = substr $line, $i+1, 1;
1316
++$i, next if $d eq '~';
1317
next if $i == length($line) - 2;
1318
$j = index $hexChars, $d;
1319
next if $j < 0;
1320
$j -= 6 if $j >= 16;
1321
my $val = $j*16;
1322
$d = substr $line, $i+2, 1;
1323
$j = index $hexChars, $d;
1324
next if $j < 0;
1325
$j -= 6 if $j >= 16;
1326
$val += $j;
1327
# We don't use this mechanism to enter normal ascii characters.
1328
next if $val >= 32 and $val < 127;
1329
# And don't stick a newline in the middle of an entered line.
1330
next if $val == 10;
1331
$c = chr $val;
1332
$i += 2;
1333
} # loop over input chars
1334
return $line2;
1335
} # readLine
1336
1337
# Read a block of lines into the buffer.
1338
sub readLines()
1339
{
1340
my $tbuf = "";
1341
# Put the pending line in first, if it's there.
1342
my $line = $linePending;
1343
$line = readLine() unless defined $line;
1344
while($line ne ".") {
1345
$tbuf .= "$line\n";
1346
$line = readLine();
1347
} # loop gathering input lines
1348
return addTextToSession(\$tbuf) if length $tbuf;
1349
$dot = $endRange;
1350
$dot = 1 if $dot == 0 and $dol;
1351
return 1;
1352
} # readLines
1353
1354
# Display a line. Show line number if $cmd is n.
1355
# Expand binary characters if $cmd is l.
1356
# Pass the line number.
1357
sub dispLine($)
1358
{
1359
my $ln = shift;
1360
print "$ln " if $cmd eq 'n';
1361
my $line = fetchLine($ln, 1);
1362
# Truncate, if the line is pathologically long.
1363
$line = substr($line, 0, 500) . "..." if length($line) > 500;
1364
print '^' if $endmarks and ($endmarks == 2 or $cmd eq 'l');
1365
if($cmd eq 'l') {
1366
$line =~ y/\10\11/<>/;
1367
$line =~ s/([\0-\x1f\x80-\xff])/sprintf("~%02x",ord($1))/ge;
1368
} else {
1369
# But we always remap return, null, and escape
1370
$line =~ s/(\00|\r|\x1b)/sprintf("~%02x",ord($1))/ge;
1371
}
1372
print $line;
1373
print dirSuffix($ln);
1374
print '$' if $endmarks and ($endmarks == 2 or $cmd eq 'l');
1375
print "\n";
1376
} # dispLine
1377
1378
# If we've printed a line in directory mode, and the entry isn't
1379
# a regular file, we've got to find and print the special character at the end.
1380
# / means directory, for example.
1381
# This is used by the previous routine, among others.
1382
sub dirSuffix($)
1383
{
1384
my $ln = shift;
1385
my $suf = "";
1386
if($fmode&$dirmode) {
1387
$suf = substr($labels, $dirSufStart + 2*$ln, 2);
1388
$suf =~ s/ +$//;
1389
}
1390
return $suf;
1391
} # dirSuffix
1392
1393
# Routines to help format a string, i.e. cut at sentence boundaries.
1394
# This isn't real smart; it will happily split Mr. Flintstone.
1395
sub appendWhiteSpace($$)
1396
{
1397
my($chunk, $breakable) = @_;
1398
my $nlc = $chunk =~ y/\n//d; # newline count
1399
if($breakable) {
1400
# Don't interrogate the last few characters of a huge string -- that's inefficient.
1401
my $short = substr $refbuf, -2;
1402
my $l = length $refbuf;
1403
$lperiod = $colno, $idxperiod = $l if $short =~ /[.!?:][)"|}]?$/;
1404
$lcomma = $colno, $idxcomma = $l if $short =~ /[-,;][)"|]?$/;
1405
$lright = $colno, $idxright = $l if $short =~ /[)"|]$/;
1406
$lany = $colno, $idxany = $l;
1407
# Tack short fragment onto previous long line.
1408
if($longcut and ($nlc or $lperiod == $colno) and $colno <= 14) {
1409
substr($refbuf, $longcut, 1) = " ";
1410
$chunk = "", $nlc = 1 unless $nlc;
1411
} # pasting small fragment onto previous line
1412
} # allowing line breaks
1413
$nlc = 0 if $lspace == 3;
1414
if($nlc) {
1415
$nlc = 1 if $lspace == 2;
1416
$refbuf .= "\n";
1417
$refbuf .= "\n" if $nlc > 1;
1418
$colno = 1;
1419
$longcut = $lperiod = $lcomma = $lright = $lany = 0;
1420
$lspace = 3 if $lspace >= 2 or $nlc > 1;
1421
$lspace = 2 if $lspace < 2;
1422
}
1423
$refbuf .= $chunk;
1424
$lspace = 1 if length $chunk;
1425
$colno += $chunk =~ y/ / /;
1426
$colno += 4 * ($chunk =~ y/\t/\t/);
1427
} # appendWhiteSpace
1428
1429
sub appendPrintable($)
1430
{
1431
my $chunk = shift;
1432
$refbuf .= $chunk;
1433
$colno += length $chunk;
1434
$lspace = 0;
1435
return if $colno <= $optimalLine;
1436
# Oops, line is getting long. Let's see where we can cut it.
1437
my ($i, $j) = (0, 0);
1438
if($lperiod > $cutLineAfter) { $i = $lperiod, $j = $idxperiod;
1439
} elsif($lcomma > $cutLineAfter) { $i = $lcomma, $j = $idxcomma;
1440
} elsif($lright > $cutLineAfter) { $i = $lright, $j = $idxright;
1441
} elsif($lany > $cutLineAfter) { $i = $lany, $j = $idxany;
1442
}
1443
return unless $j; # nothing we can do about it
1444
$longcut = 0;
1445
$longcut = $j if $i != $lperiod;
1446
substr($refbuf, $j, 1) = "\n";
1447
$colno -= $i;
1448
$lperiod -= $i;
1449
$lcomma -= $i;
1450
$lright -= $i;
1451
$lany -= $i;
1452
} # appendPrintable
1453
1454
# Break up a line using the above routines.
1455
sub breakLine($)
1456
{
1457
my $t = shift;
1458
my $ud = $$t =~ s/\r$//;
1459
if($lspace eq "2l") {
1460
$$t =~ s/^/\r/ if length $$t;
1461
$lspace = 2;
1462
}
1463
$$t =~ s/^/\r/ if length $$t > $paraLine;
1464
my $rc = $$t =~ y/\r/\n/;
1465
$ud |= $$t =~ s/[ \t]+$//gm;
1466
$ud |= $$t =~ s/([^ \t\n])[ \t]{2,}/$1 /g;
1467
$ud |= $$t =~ s/([^ \t\n])\t/$1 /g;
1468
$ud |= $$t =~ s/ +\t/\t/g;
1469
$lspace = 2 if $lspace < 2; # should never happen
1470
$lspace = 3 unless length $$t;
1471
return $ud if ! $rc and length $$t < $optimalLine;
1472
$rc |= $ud;
1473
# The following 120 comes from $paraLine.
1474
$$t =~ s/(\n.{120})/\n$1/g;
1475
$$t =~ s/(.{120,}\n)/$1\n/g;
1476
$refbuf = "";
1477
$colno = 1;
1478
$longcut = $lperiod = $lcomma = $lright = $lany = 0;
1479
while($$t =~ /(\s+|[^\s]+)/g) {
1480
my $chunk = $1;
1481
if($chunk =~ /\s/) { appendWhiteSpace($chunk, 1); } else { appendPrintable($chunk); }
1482
}
1483
if($lspace < 2) { # line didn't have a \r at the end
1484
# We might want to paste the last word back on.
1485
appendWhiteSpace("\n", 1);
1486
chop $refbuf;
1487
}
1488
$rc = 1 if $refbuf =~ /\n/;
1489
return 0 unless $rc;
1490
$$t = $refbuf;
1491
$lspace = "2l" if length $refbuf > $paraLine;
1492
return 1;
1493
} # breakLine
1494
1495
# Check the syntax of a regular expression, before we pass it to perl.
1496
# If perl doesn't like it, it dies, and you've lost your edits.
1497
# The first char is the delimiter -- we stop at the next delimiter.
1498
# The regexp, up to the second delimiter, is returned,
1499
# along with the remainder of the string in the second return variable.
1500
# return (regexp, remainder), or return () if there is a problem.
1501
# As usual, $errorMsg will be set.
1502
# Pass the line containing the regexp, and a flag indicating
1503
# left or right side of a substitute.
1504
sub regexpCheck($$)
1505
{
1506
my ($line, $isleft) = @_;
1507
my ($c, $d);
1508
# We wouldn't be here if the line was empty.
1509
my $delim = substr $line, 0, 1;
1510
index($valid_delim, $delim) >= 0 or
1511
$errorMsg = "invalid delimiter $delim", return ();
1512
$line = substr $line, 1; # remove lead delimiter
1513
# Remember whether a character is "on deck", ready to be modified by * etc.
1514
my $ondeck = 0;
1515
my $offdeck = ' ';
1516
my $exp = "";
1517
my $cc = 0; # in character class
1518
my $paren = 0; # nested parentheses
1519
1520
while(length $line) {
1521
$c = substr $line, 0, 1;
1522
if($c eq '\\') {
1523
$errorMsg = "line ends in backslash", return () if length($line) == 1;
1524
$d = substr $line, 1, 1;
1525
$ondeck = 1;
1526
$offdeck = ' ';
1527
# I can't think of any reason to remove the escape \ from any character,
1528
# except ()|, where we reverse the sense of escape,
1529
# and \& on the right, which becomes &.
1530
if(index("()|", $d) >= 0 and ! $cc and $isleft) {
1531
$ondeck = 0, ++$paren if $c eq '(';
1532
--$paren if $c eq ')';
1533
$errorMsg = "Unexpected closing )", return () if $paren < 0;
1534
$c = '';
1535
}
1536
$c = '' if $d eq '&' and ! $isleft;
1537
$exp .= "$c$d";
1538
$line = substr $line, 2;
1539
next;
1540
} # escape character
1541
1542
# Break out if you've hit the delimiter
1543
$paren or $c ne $delim or last;
1544
1545
# Not the delimiter, I'll assume I can copy it over to $exp.
1546
# But I have to watch out for slash, which is *my* delimiter.
1547
$exp .= '\\' if $c eq '/';
1548
# Then there's ()|, which I am reversing the sense of escape.
1549
$exp .= '\\' if index("()|", $c) >= 0 and $isleft;
1550
# Sometimes $ is interpolated when I don't want it to be.
1551
# Even if there is no alphanumeric following, a bare $ seems to cause trouble.
1552
# Escape it, unless followed by delimiter, or digit (rhs).
1553
if($c eq '$') {
1554
$exp .= '\\' if $isleft and
1555
length($line) > 1 and substr($line, 1, 1) ne $delim;
1556
$exp .= '\\' if ! $isleft and
1557
$line !~ /^\$\d/;
1558
}
1559
if($c eq '^') {
1560
$exp .= '\\' if $isleft and $cc != length $exp;
1561
}
1562
# And we have to escape every @, to avoid interpolation.
1563
# Good thing we don't have to escape %,
1564
# or it might mess up our % remembered rhs logic.
1565
$exp .= '\\' if $c eq '@';
1566
# Turn & into $&
1567
$exp .= '$' if $c eq '&' and ! $isleft;
1568
# Finally push the character.
1569
$exp .= $c;
1570
$line = substr $line, 1;
1571
1572
# Are there any syntax checks I need to make on the rhs?
1573
# I don't think so.
1574
next if ! $isleft;
1575
1576
if($cc) { # character class
1577
# All that matters here is the ]
1578
$cc = 0 if $c eq ']';
1579
next;
1580
}
1581
1582
# Modifiers must have a preceding character.
1583
# Except ? which can reduce the greediness of the others.
1584
if($c eq '?' and $offdeck ne '?') {
1585
$ondeck = 0;
1586
$offdeck = '?';
1587
next;
1588
}
1589
1590
if(index("?+*", $c) >= 0 or
1591
$c eq '{' and $line =~ s/^(\d+,?\d*})//) {
1592
my $mod = ( $c eq '{' ? "{$1" : $c);
1593
$errorMsg = "$mod modifier has no preceding character", return () if ! $ondeck;
1594
$ondeck = 0;
1595
$offdeck = $c;
1596
$exp .= "$1" if $c eq '{';
1597
next;
1598
} # modifier
1599
1600
$ondeck = 1;
1601
$offdeck = ' ';
1602
$cc = length $exp if $c eq '[';
1603
} # loop over chars in the pattern
1604
1605
$cc == 0 or
1606
$errorMsg = "no closing ]", return ();
1607
$paren == 0 or
1608
$errorMsg = "no closing )", return ();
1609
if(! length $exp and $isleft) {
1610
$exp = $savelhs;
1611
$errorMsg = "no remembered search string", return () if ! defined $exp;
1612
}
1613
$savelhs = $exp if $isleft;
1614
if(! $isleft) {
1615
if($exp eq '%') {
1616
$exp = $saverhs;
1617
$errorMsg = "no remembered replacement string", return () if ! defined $exp;
1618
} elsif($exp eq '\\%') {
1619
$exp = '%';
1620
}
1621
$saverhs = $exp;
1622
} # rhs
1623
1624
return ($exp, $line);
1625
} # regexpCheck
1626
1627
# Get the start or end of a range.
1628
# Pass the line containing the address.
1629
sub getRangePart($)
1630
{
1631
my $line = shift;
1632
my $ln = $dot;
1633
if($line =~ s/^(\d+)//) {
1634
$ln = $1;
1635
} elsif($line =~ s/^\.//) {
1636
# $ln is already set to dot
1637
} elsif($line =~ s/^\$//) {
1638
$ln = $dol;
1639
} elsif($line =~ s/^'([a-z])//) {
1640
$ln = substr $labels, (ord($1) - ord('a'))*$lnwidth, $lnwidth;
1641
$errorMsg = "label $1 not set", return () if $ln eq $lnspace;
1642
} elsif($line =~ m:^([/?]):) {
1643
$errorMsg = "search string not found", return () if $dot == 0;
1644
my $delim = $1;
1645
my @pieces = regexpCheck($line, 1);
1646
return () if $#pieces < 0;
1647
my $exp = $pieces[0];
1648
$line = $pieces[1];
1649
my $icase = ""; # case independent
1650
$icase = "i" if $caseInsensitive;
1651
if($delim eq substr $line, 0, 1) {
1652
$line = substr $line, 1;
1653
if('i' eq substr $line, 0, 1) {
1654
$line = substr $line, 1;
1655
$icase = 'i';
1656
}
1657
}
1658
my $incr = ($delim eq '/' ? 1 : -1);
1659
# Recompile the regexp after each command, but don't compile it on every line.
1660
# Is there a better way to do this, besides using eval?
1661
my $notfound = 0;
1662
eval '
1663
while(1) {
1664
$ln += $incr;
1665
$ln = 1 if $ln > $dol;
1666
$ln = $dol if $ln == 0;
1667
last if fetchLine($ln, 1) =~ ' .
1668
"/$exp/o$icase; " .
1669
'$notfound = 1, last if $ln == $dot;
1670
} # looking for match
1671
'; # end evaluated string
1672
$errorMsg = "search string not found", return () if $notfound;
1673
} # search pattern
1674
# Now add or subtract from this base line number
1675
while($line =~ s/^([+-])(\d*)//) {
1676
my $add = ($2 eq "" ? 1 : $2);
1677
$ln += ($1 eq '+' ? $add : -$add);
1678
}
1679
$errorMsg = "line number too large", return ()
1680
if $ln > $dol;
1681
$errorMsg = "negative line number", return ()
1682
if $ln < 0;
1683
return ($ln, $line);
1684
} # getRangePart
1685
1686
# Read the data as a string from a url.
1687
# Data is retrieved using http, https, or ftp.
1688
# Parameters: url, post data, result buffer.
1689
# You can return 0 (failure) and leave text and the buffer,
1690
# and I'll report the error, and still assimilate the buffer.
1691
sub readUrl($$$)
1692
{
1693
my ($filename, $post, $tbuf) = @_;
1694
my $rc = 1; # return code, success
1695
$lfsz = 0; # local file size
1696
my $rsize = 0; # size read
1697
my $weburl;
1698
my $scheme;
1699
my $encoding = "";
1700
my $pagetype = "";
1701
my %url_desc = (); # Description of the current URL
1702
1703
# I don't know if we need a full url encode or what??
1704
# This is a major kludge! I just don't understand this.
1705
$filename =~ s/ /%20/g;
1706
$filename =~ s/[\t\r\n]//g;
1707
# I don't know what http://foo@this.that.com/file.htm means,
1708
# but I see it all the time.
1709
$filename =~ s,^http://[^/]*@,http://,i;
1710
1711
$$tbuf = ""; # start with a clear buffer
1712
$errorMsg = "too many nested frames", return 0 unless $rerouteCount;
1713
--$rerouteCount;
1714
1715
# split into machine, file, and post parameters
1716
separate: {
1717
my $oldname = $filename; # remember where we started
1718
my $authinfo = ""; # login password for web sites that return error 401
1719
1720
$scheme = is_url $filename; # scheme could have changed
1721
$weburl = 0;
1722
$weburl = 1 if $scheme =~ /^https?$/;
1723
if(!length $post and $filename =~ s/^(.*)(\?[^\s]*)$/$1/ ) {
1724
$post = $2;
1725
}
1726
my $postfilename = "";
1727
# We assume $post starts with ? or *, if it is present at all.
1728
my $meth = "GET";
1729
my $postapplic = "";
1730
if(substr($post, 0, 1) eq '*') {
1731
$meth = "POST";
1732
} else {
1733
$postfilename = $post;
1734
}
1735
print "$meth: $post\n" if $debug >= 2;
1736
1737
$filename =~ s,^$scheme://,,i;
1738
my $serverPort = 80;
1739
$serverPort = 443 if $scheme eq 'https';
1740
$serverPort = 21 if $scheme eq 'ftp';
1741
$serverPort = 23 if $scheme eq 'telnet';
1742
my $serverPortString = "";
1743
my $server = $filename;
1744
$server =~ s,/.*,,;
1745
# Sometimes we need to do this -- got me hanging!
1746
$server =~ s/%([0-9a-fA-F]{2})/chr hex "$1"/ge;
1747
if($server =~ s/:(\d+)$//) {
1748
$serverPort = $1;
1749
}
1750
# If a server is on port 443, assume it speaks SSL.
1751
# This is a real bastardization of the html standard,
1752
# but it's the explorer standard. Need I say more?
1753
$scheme = 'https' if$serverPort == 443;
1754
$serverPortString = ":$serverPort" if $serverPort != 80;
1755
$filename =~ s,^[^/]*,,;
1756
1757
# Lots of http servers can't handle /./ or /../ or //
1758
$filename =~ s:/{2,}:/:g;
1759
# Oops, put internal http:// back the way it was.
1760
# The bug is caused by a line like this.
1761
# <form method=post action=server/file?this=that&return=http://someOtherServer/blah>
1762
# Because it's post, the get parameters after the ? are still here.
1763
# And I just turned http:// into http:/
1764
# This is very rare, but it happened to me, so I'm trying to fix it.
1765
$filename =~ s,http:/,http://,gi;
1766
$filename =~ s,ftp:/,ftp://,gi;
1767
$filename =~ s:^/(\.{1,2}/)+:/:;
1768
$filename =~ s:/(\./)+:/:g;
1769
1 while $filename =~ s:/[^/]+/\.\./:/:;
1770
$filename =~ s:^/(\.\./)+:/:;
1771
1772
# Ok, create some more variables so we either fetch this file
1773
# or convert it if it's pdf.
1774
# Too bad I did all this work, and the pdf converter doesn't work for crap.
1775
# Probably because pdf is irreparably inaccessible.
1776
# Thanks a lot adobe!
1777
my $go_server = $server;
1778
my $go_port = $serverPort;
1779
my $go_portString = $serverPortString;
1780
my $go_file = $filename;
1781
my $go_post = $post;
1782
my $go_postfilename = $postfilename;
1783
my $go_meth = $meth;
1784
1785
if($filename =~ /\.pdf$/ and $pdf_convert) {
1786
($meth eq "GET" and $scheme eq "http") or
1787
$errorMsg = "online conversion from pdf to html only works when the pdf file is accessed via the http get method\ntype pr to download pdf in raw mode", return 0;
1788
$go_server="access.adobe.com";
1789
$go_port = 80;
1790
$go_portString = "";
1791
$go_file = "/perl/convertPDF.pl";
1792
# It would be simpler if this bloody form wer get, but it's post.
1793
$go_meth = "POST";
1794
$go_post = "http://$server$serverPortString$filename$postfilename";
1795
$go_post = "*submit=submit&url=" . urlEncode($go_post);
1796
$go_postfilename = "";
1797
} # redirecting to adobe to convert pdf
1798
1799
if($go_meth eq "POST") {
1800
$postapplic =
1801
"Pragma: no-cache$eol" .
1802
"Cache-Control: no-cache$eol" .
1803
"Content-Type: application/x-www-form-urlencoded$eol" .
1804
"Content-Length: " . (length($go_post)-1) . $eol;
1805
}
1806
1807
my $newname = "";
1808
1809
$authAttempt = 0;
1810
makeconnect: {
1811
my $chunk;
1812
$lfsz = 0;
1813
$$tbuf = "";
1814
$go_file = "/" if ! length $go_file;
1815
%url_desc = (SCHEME => $scheme, SERVER => $go_server, PORT => $go_port, PATH => $go_file, method => $go_meth);
1816
$url_desc{content} = substr($go_post, 1) if length $go_post; # Kinda silly.
1817
# If you're using digest authentication with the POST method,
1818
# the content needs to be digestified.
1819
# This is for message integrity checking, when that option is used.
1820
# Consider completely replacing $go_x variables with elements of the %url_desc
1821
# hash? There is massive redundancy here.
1822
my $domainCookies = "";
1823
$domainCookies = fetchCookies(\%url_desc) if $allowCookies; # Grab the cookies.
1824
my $send_server = # Send this to the http server - maybe via SSL
1825
"$go_meth $go_file$go_postfilename HTTP/1.0$eol" .
1826
# Do we need $go_portString here???
1827
# If I put it in, paypal doesn't work.
1828
"Host: $go_server$eol" .
1829
(length $referer ? "Referer: $referer$eol" : "") .
1830
$domainCookies .
1831
$authinfo .
1832
"Accept: text/*, audio/*, image/*, application/*, message/*$eol" .
1833
"Accept: audio-file, postscript-file, mail-file, default, */*;q=0.01$eol" .
1834
"Accept-Encoding: gzip, compress$eol" .
1835
"Accept-Language: en$eol" .
1836
"User-Agent: $agent$eol" .
1837
$postapplic .
1838
$eol; # blank line at the end
1839
1840
# send data after if post method
1841
$send_server .= substr($go_post, 1) if $go_meth eq "POST";
1842
1843
if($debug >= 4) {
1844
my $temp_server = $send_server;
1845
$temp_server =~ y/\r//d;
1846
print $temp_server;
1847
}
1848
1849
if($scheme eq 'http') {
1850
# Connect to the http server.
1851
my $iaddr = inet_aton($go_server) or
1852
$errorMsg = "cannot identify $go_server on the network", return 0;
1853
my $paddr = sockaddr_in($go_port, $iaddr);
1854
my $proto = getprotobyname('tcp');
1855
socket(FH, PF_INET, SOCK_STREAM, $proto) or
1856
$errorMsg = "cannot allocate a socket", return 0;
1857
connect(FH, $paddr) or
1858
$errorMsg = "cannot connect to $go_server", return 0;
1859
FH->autoflush(1);
1860
1861
print FH $send_server; # Send the HTTP request message
1862
1863
# Now retrieve the page and update the user after every 100K of data.
1864
my $last_fk = 0;
1865
STDOUT->autoflush(1) if ! $doslike;
1866
while(defined($rsize = sysread FH, $chunk, 100000)) {
1867
print "sockread $rsize\n" if $debug >= 5;
1868
$$tbuf .= $chunk;
1869
$lfsz += $rsize;
1870
last if $rsize == 0;
1871
my $fk = int($lfsz/100000);
1872
if($fk > $last_fk) {
1873
print ".";
1874
$last_fk = $fk;
1875
}
1876
last if $lfsz >= $maxfile;
1877
}
1878
close FH;
1879
print "\n" if $last_fk;
1880
STDOUT->autoflush(0) if ! $doslike;
1881
$lfsz <= $maxfile or
1882
$errorMsg = "file is too large, limit 40MB", return 0;
1883
defined $rsize or
1884
$$tbuf = "", $errorMsg = "error reading data from the socket", return 0;
1885
1886
} elsif ($scheme eq 'https') {
1887
$lfsz = do_ssl($go_server, $go_port, $send_server, $tbuf);
1888
Net::SSLeay::free($ssl) if defined $ssl;
1889
Net::SSLeay::CTX_free($ctx) if defined $ctx;
1890
return 0 unless $lfsz;
1891
1892
} elsif ($scheme eq 'ftp') {
1893
$lfsz = ftp_connect($go_server, $go_port, $go_file, $tbuf);
1894
return 0 unless $lfsz;
1895
1896
} elsif ($scheme eq "telnet") {
1897
if($go_server =~ s/^([^:@]*):([^:@]*)@//) {
1898
print "This URL gives a suggested username of $1 and password of $2\n" .
1899
"to be used with the telnet connection you are about to establish.\n";
1900
# See RFC 1738, section 3.8. The username and password in a telnet URL
1901
# are advisory. There is no standard method of logging into telnet services.
1902
# I guess this is especially useful for public services, which offer guest accounts and such.
1903
}
1904
print "Starting telnet.\n";
1905
system("telnet $go_server $go_port");
1906
return 1;
1907
1908
} else {
1909
$errorMsg = "this browser cannot access $scheme URLs.", return 0;
1910
}
1911
1912
# We got the web page.
1913
# But it might be a redirection to another url.
1914
if($weburl and $$tbuf =~ /^http\/[\d.]+ 30[12]/i) {
1915
if($$tbuf =~ /\nlocation:[ \t]+([^\s]+)[ \t\r]*\n/i) {
1916
$newname = $1;
1917
print "relocate $newname\n" if $debug >= 2;
1918
}}
1919
1920
if($rc and
1921
! length $newname and
1922
# Some web sites serve up pages with no headers at all!
1923
# aspace.whizy.com/forum/ultimate.cgi
1924
$$tbuf =~ /^http/i and
1925
$$tbuf =~ /^http\/[\d.]+ 404 /i) {
1926
$errorMsg = "file not found on the remote server";
1927
$rc = 0;
1928
} # not found
1929
1930
# there is yet another way to redirect to a url
1931
if($rc and $$tbuf =~ /<meta +http-equiv=["']?refresh[^<>]*(url=|\d+;)['"]?([^'">\s]+)/i) {
1932
$newname = $2;
1933
print "refresh $newname\n" if $debug >= 2;
1934
# This is almost always an absolute url, even without the http prefix,
1935
# but sometimes it's relative. Got me hanging!
1936
# Here's a looser criterion for web url.
1937
if($newname =~ /^[\w,-]+\.[\w,-]+\.[\w,-]/) {
1938
$newname = "http://$newname";
1939
}
1940
}
1941
1942
# Extract information from the http header - primarily cookies.
1943
$encoding = $pagetype = "";
1944
if($$tbuf =~ s/^(http\/\d.*?\r?\n\r?\n)//si) {
1945
my $header = $1;
1946
my @lines = split "\n", $header;
1947
open BFH, ">>$ebhttp";
1948
if(defined BFH) {
1949
print BFH $header;
1950
close BFH;
1951
}
1952
$authinfo = "";
1953
while(my $hline = shift @lines) {
1954
$hline =~ s/\r$//;
1955
print "$hline\n" if $debug >= 4;
1956
setCookies($hline, \%url_desc) if $hline =~ /^Set-Cookie:/i and $allowCookies;
1957
$authinfo = parseWWWAuth($hline, \%url_desc) if $hline =~ /^WWW-Authenticate/i;
1958
return 0 if $authinfo eq "x";
1959
# I shouldn't really discard things like charset=blablabla,
1960
# but I don't really know what to do with it anyways.
1961
$hline =~s/;.*//;
1962
$encoding = lc $1 if $hline =~ /^content-encoding:\s+['"]?(\w+)['"]?\s*$/i;
1963
$pagetype = lc $1 if $hline =~ /^content-type:\s+['"]?([^\s'"]+)['"]?\s*$/i;
1964
} # loop over lines
1965
++$authAttempt, redo makeconnect if length $authinfo;
1966
} else { # http header extracted
1967
if($scheme =~ /^https?$/) {
1968
$errorMsg = "http response doesn't have a head-body structure";
1969
$rc = 0;
1970
} else {
1971
# For now, this means ftp.
1972
# We could have retrieved an html page via ftp, but probably not.
1973
# Turn off browse command.
1974
$cmd = 'e' unless $$tbuf =~ /^<[hH!]/;
1975
}
1976
}
1977
} # makeconnect
1978
1979
# cookies that are set via http-equiv
1980
# The content of the cookie must be quoted.
1981
while($$tbuf =~ /<meta +http-equiv=["']?set-cookie['" ]+content="([^"]*)"/gi) {
1982
setCookies($1, \%url_desc);
1983
}
1984
while($$tbuf =~ /<meta +http-equiv=["']?set-cookie['" ]+content='([^']*)'/gi) {
1985
setCookies($1, \%url_desc);
1986
}
1987
1988
if($rc and $reroute and length $newname) {
1989
$newname = resolveUrl("$scheme://$server$serverPortString$filename", $newname);
1990
print "becomes $newname\n" if $debug >= 2;
1991
if($newname ne $oldname) {
1992
# It's not really diferent if one has :80 and the other doesn't.
1993
# I wouldn't code this up if it didn't really happen. See www.claritin.com
1994
$oldname =~ s,^HTTP://,http://,;
1995
$oldname =~ s,^(http://)?([^/]*):80/,$1$2/,;
1996
$oldname =~ s,^(http://)?([^/]*):80$,$1$2,;
1997
$newname =~ s,^HTTP://,http://,;
1998
$newname =~ s,^(http://)?([^/]*):80/,$1$2/,;
1999
$newname =~ s,^(http://)?([^/]*):80$,$1$2,;
2000
if($oldname ne $newname) {
2001
if(--$rerouteCount) {
2002
print "$newname\n" if $debug >= 1;
2003
# Post method becomes get after redirection, I think.
2004
# $post = "" if length $post and $newname =~ /\?[^\/]*$/;
2005
$post = "";
2006
$filename = $newname;
2007
redo separate;
2008
}
2009
$errorMsg = "too many url redirections";
2010
$rc = 0;
2011
}}} # automatic url redirection
2012
2013
$changeFname = "$scheme://$server$serverPortString$filename$postfilename";
2014
} # separate
2015
2016
# Check for complressed data.
2017
if($rc and $lfsz and length $encoding and $pagetype =~ /^text/i) {
2018
print "$lfsz\ndecoding $encoding\n" if $debug >= 2;
2019
my $program = "";
2020
my $csuf = ""; # compression suffix
2021
$program = "zcat", $csuf = "gz" if $encoding eq "gzip";
2022
$program = "zcat", $csuf = "Z" if $encoding eq "compress";
2023
length $program or
2024
$errorMsg = "unrecognized compression method", return 0;
2025
$cfn = "$ebtmp.$csuf"; # compressed file name
2026
open FH, ">$cfn" or
2027
$errorMsg = "cannot create temp file $cfn", return 0;
2028
binmode FH, ':raw' if $doslike;
2029
print FH $$tbuf or
2030
$errorMsg = "cannot write to temp file $cfn", return 0;
2031
close FH;
2032
unlink $ebtmp;
2033
if(! system "$program $ebtmp.$csuf >$ebtmp 2>/dev/null") {
2034
# There are web pages out there that are improperly compressed.
2035
# We'll call it good if we got any data at all.
2036
$errorMsg = "could not uncompress the data", return 0 unless (stat($ebtmp))[7];
2037
}
2038
2039
# Read in the uncompressed data.
2040
$$tbuf = "";
2041
open FH, $ebtmp or
2042
$errorMsg = "cannot open the uncompressed file $ebtmp", return 0;
2043
$lfsz = (stat(FH))[7];
2044
$lfsz <= $maxfile or
2045
$errorMsg = "uncompressed file is too large, limit 40MB", close FH, return 0;
2046
binmode FH, ':raw' if $doslike;
2047
$rsize = sysread FH, $$tbuf, $lfsz;
2048
close FH;
2049
$rsize and $rsize == $lfsz or
2050
$errorMsg = "cannot read the uncompressed data from $ebtmp", return 0;
2051
unlink $ebtmp;
2052
} # compressed data
2053
2054
if($rc and $fetchFrames) {
2055
$errorMsg = "";
2056
# This really isn't right - to do this here I mean.
2057
# If a line of javascript happens to contain a frame tag
2058
# I'm going to fetch that frame and put it in right here.
2059
# Hopefully that won't happen.
2060
# Note that the entire frame tag must be on one line.
2061
$$tbuf =~ s/(<frame\b[^<>\0\x80-\xff]+>)/readFrame($1)/gei;
2062
$rc = 0 if length $errorMsg;
2063
} # looking for frames
2064
2065
return $rc;
2066
} # readUrl
2067
2068
# Read a frame.
2069
sub readFrame($)
2070
{
2071
my $tag = shift;
2072
my $saveFname = $changeFname;
2073
my($tc, $fbuf, $src, $name);
2074
2075
$tag =~ s/\bsrc *= */src=/gi;
2076
$tag =~ s/\bname *= */name=/gi;
2077
$tc = $tag;
2078
if($tc =~ s/^.*\bsrc=//s) {
2079
$src = $tc;
2080
$src =~ s/ .*//s;
2081
$src =~ s/^['"]//;
2082
$src =~ s/['"]?>?$//;
2083
if(length $src) {
2084
print "fetch frame $src\n" if $debug >= 1;
2085
$src = resolveUrl($saveFname, $src);
2086
if($didFrame{$src}) {
2087
print "already fetched\n" if $debug >= 2;
2088
$changeFname = $saveFname;
2089
return "";
2090
}
2091
$didFrame{$src} = 1;
2092
print "* $src\n" if $debug >= 1;
2093
2094
$name = "";
2095
$tc = $tag;
2096
if($tc =~ s/^.*\bname=//s) {
2097
$tc =~ s/ .*//s;
2098
$tc =~ s/^['"]//;
2099
$tc =~ s/['"]?>?$//;
2100
$name = urlDecode $tc if length $tc;
2101
} # name attribute
2102
2103
if(readUrl($src, "", \$fbuf)) {
2104
# Replace the tag with the data, and some stuff prepended.
2105
$name = " $name" if length $name;
2106
$tag = "<H2> Frame$name: </H2>\n<base href=" .
2107
urlEncode($changeFname) . ">\n";
2108
$changeFname = $saveFname;
2109
return $tag.$fbuf;
2110
} # frame read successfully
2111
}} # src attribute present
2112
2113
$changeFname = $saveFname;
2114
return $tag;
2115
} # readFrame
2116
2117
# Adjust the map of line numbers -- we have inserted text.
2118
# Also shift the downstream labels.
2119
# Pass the string containing the new line numbers, and the dest line number.
2120
sub addToMap($$)
2121
{
2122
my ($newpiece, $dln) = @_;
2123
my $offset = length($newpiece)/$lnwidth;
2124
$offset > 0 or
2125
die "negative offset in addToMap";
2126
my ($i, $j);
2127
foreach $i (0..25) {
2128
my $ln = substr($labels, $i*$lnwidth, $lnwidth); # line number
2129
next if $ln eq $lnspace or $ln <= $dln;
2130
substr($labels, $i*$lnwidth, $lnwidth) =
2131
sprintf($lnformat, $ln + $offset);
2132
} # loop over 26 labels
2133
$j = ($dln+1) * $lnwidth;
2134
substr($map, $j, 0) = $newpiece;
2135
$dot = $dln + $offset;
2136
$dol += $offset;
2137
$fmode |= $changemode|$firstopmode;
2138
$ubackup = 1;
2139
} # addToMap
2140
2141
# Fold in the text buffer (parameter) at $endRange (global variable).
2142
# Assumes the text has the last newline on it.
2143
sub addTextToSession($)
2144
{
2145
my $tbuf = shift; # text buffer
2146
return 1 unless length $$tbuf;
2147
$fmode &= ~$nlmode if $endRange == $dol;
2148
if(not $$tbuf =~ s/\n$// and
2149
$endRange == $dol) {
2150
$fmode |= $nlmode;
2151
print "no trailing newline\n" if ! ($fmode&$binmode) and $cmd ne 'b';
2152
} # missing newline
2153
my $j = $#text;
2154
my $newpiece = "";
2155
# At this point $tbuf could be empty, whence split doesn't work properly.
2156
# This only happens when reading a file containing one blank line.
2157
if(length $$tbuf) {
2158
push @text, split "\n", $$tbuf, -1;
2159
} else {
2160
push @text, "";
2161
}
2162
$#text = $j, return 0 if lineLimit 0;
2163
$newpiece .= sprintf($lnformat, $j) while ++$j <= $#text;
2164
addToMap($newpiece, $endRange);
2165
return 1;
2166
} # addTextToSession
2167
2168
# Read a file into memory.
2169
# As described earlier, the lines are appended to @text.
2170
# Then the indexes for those lines are pasted into $map,
2171
# using addToMap().
2172
# Check to see if the data is binary, and set $fmode accordingly.
2173
# Parameters are the filename or URL, and the post data (for URLs).
2174
sub readFile($$)
2175
{
2176
my ($filename, $post) = @_;
2177
my $tbuf; # text buffer
2178
my $rc = 1; # return code, success
2179
$filesize = 0;
2180
my $rsize = 0; # size read
2181
my $j;
2182
2183
if(is_url $filename) {
2184
$rerouteCount = 24;
2185
%didFrame = ();
2186
$rc = readUrl($filename, $post, \$tbuf);
2187
$filesize = length $tbuf;
2188
return 0 unless $rc + $filesize;
2189
} else { # url or file
2190
2191
open FH, "<$filename" or
2192
$errorMsg = "cannot open $filename, $!", return 0;
2193
2194
# Check for directory here
2195
if(-d FH) {
2196
close FH;
2197
$j = $filename;
2198
$j =~ s,/$,,;
2199
$j .= "/*";
2200
my @dirlist;
2201
if($j =~ / /) {
2202
@dirlist = glob '"'.$j.'"';
2203
} else {
2204
@dirlist = glob $j;
2205
}
2206
if($#dirlist < 0) {
2207
$dot = $endRange;
2208
$filesize = 0;
2209
return $rc;
2210
} # empty directory
2211
$dirname = $j;
2212
$dirname =~ s/..$//; # get rid of /*
2213
return 0 if lineLimit($#dirlist + 1);
2214
$filesize = 0;
2215
$tbuf = "";
2216
$j = $dirSufStart;
2217
substr($labels, $j, 2) = " ";
2218
foreach (@dirlist) {
2219
my $entry = $_;
2220
$entry =~ s,.*/,,; # leave only the file
2221
$entry =~ s/\n/\t/g;
2222
my $suf = "";
2223
$suf .= '@' if -l;
2224
if(! -f) {
2225
$suf .= '/' if -d;
2226
$suf .= '|' if -p;
2227
$suf .= '*' if -b;
2228
$suf .= '<' if -c;
2229
$suf .= '^' if -S;
2230
} # not a regular file
2231
$filesize += length($entry) + length($suf) + 1;
2232
if($dol) {
2233
$entry .= $suf;
2234
} else {
2235
$suf .= " ";
2236
$j += 2;
2237
substr($labels, $j, 2) = substr($suf, 0, 2);
2238
}
2239
$tbuf .= "$entry\n";
2240
}
2241
$dol or $fmode = $dirmode, print "directory mode\n";
2242
return addTextToSession(\$tbuf);
2243
} # directory
2244
2245
-f FH or $errorMsg = "$filename is not a regular file", close FH, return 0;
2246
$filesize = (stat(FH))[7];
2247
if(! $filesize) {
2248
close FH;
2249
$dot = $endRange;
2250
$filesize = 0;
2251
return $rc;
2252
} # empty file
2253
$filesize <= $maxfile or
2254
$errorMsg = "file is too large, limit 40MB", close FH, return 0;
2255
binmode FH, ':raw' if $doslike;
2256
$rsize = sysread(FH, $tbuf, $filesize) if $filesize;
2257
close FH;
2258
$rsize == $filesize or
2259
$errorMsg = "cannot read the contents of $filename,$!", return 0;
2260
} # reading url or regular file
2261
2262
my $bincount = $tbuf =~ y/\0\x80-\xff/\0\x80-\xff/;
2263
if($bincount*4 - 10 < $filesize) {
2264
# A text file - remove crlf in the dos world.
2265
$tbuf =~ s/\r\n/\n/g if $doslike;
2266
} elsif(! ($fmode&$binmode)) {
2267
# If it wasn't before, it is now a binary file.
2268
print "binary data\n";
2269
$fmode |= $binmode;
2270
}
2271
2272
$rc &= addTextToSession(\$tbuf);
2273
return $rc;
2274
} # readFile
2275
2276
# Write a range into a file.
2277
# Pass the mode and filename.
2278
sub writeFile($$)
2279
{
2280
my ($mode, $filename) = @_;
2281
$errorMsg = "cannot write to a url", return 0 if is_url($filename);
2282
$dol or $errorMsg = "writing an empty file", return 0;
2283
open FH, "$mode$filename" or
2284
$errorMsg = "cannot create $filename, $!", return 0;
2285
$filesize = 0;
2286
binmode FH, ':raw' if $doslike and $fmode&$binmode;
2287
if($startRange) {
2288
foreach my $i ($startRange..$endRange) {
2289
my $nl = ($fmode&$nlmode && $i == $dol ? "" : "\n");
2290
my $suf = dirSuffix($i);
2291
my $outline = fetchLine($i, 1).$suf.$nl;
2292
print FH $outline or
2293
$errorMsg = "cannot write to $filename, $!", close FH, return 0;
2294
$filesize += length $outline;
2295
} # loop over range
2296
} # nonempty file
2297
close FH;
2298
# This is not an undoable operation, nor does it change data.
2299
# In fact the data is "no longer modified" if we have written all of it.
2300
$fmode &= ~$changemode if $dol == 0 or $startRange == 1 and $endRange == $dol;
2301
return 1;
2302
} # writeFile
2303
2304
# Read from another context.
2305
# Pass the context number.
2306
sub readContext($)
2307
{
2308
my $cx = shift;
2309
cxCompare($cx) and cxActive($cx) or return 0;
2310
my $dolcx = $dol[$cx];
2311
$filesize = 0;
2312
if($dolcx) {
2313
return 0 if lineLimit $dolcx;
2314
$fmode &= ~$nlmode if $endRange == $dol;
2315
my $newpiece = "";
2316
foreach my $i (1..$dolcx) {
2317
my $inline = fetchLineContext($i, 1, $cx);
2318
my $suf = "";
2319
if($fmode[$cx] & $dirmode) {
2320
$suf = substr($labels[$cx], $dirSufStart + 2*$i, 2);
2321
$suf =~ s/ +$//;
2322
}
2323
$inline .= $suf;
2324
push @text, $inline;
2325
$newpiece .= sprintf $lnformat, $#text;
2326
$filesize += length($inline) + 1;
2327
} # end loop copying lines
2328
addToMap($newpiece, $endRange);
2329
if($fmode[$cx]&$nlmode) {
2330
--$filesize;
2331
$fmode |= $nlmode if $endRange == $dol;
2332
}
2333
$fmode |= $binmode, print "binary data\n"
2334
if $fmode[$cx]&$binmode and ! ($fmode&$binmode);
2335
} # nonempty buffer
2336
return 1;
2337
} # readContext
2338
2339
# Write to another context.
2340
# Pass the context number.
2341
sub writeContext($)
2342
{
2343
my $cx = shift;
2344
my $dolcx = $endRange - $startRange + 1;
2345
$dolcx = 0 if ! $startRange;
2346
return 0 if ! cxCompare($cx) or !cxReset($cx, 1) or lineLimit $dolcx;
2347
my $mapcx = $lnspace;
2348
$filesize = 0;
2349
if($startRange) {
2350
foreach my $i ($startRange..$endRange) {
2351
$outline = fetchLine($i, 0);
2352
$outline .= dirSuffix($i);
2353
push @text, $outline;
2354
$mapcx .= sprintf $lnformat, $#text;
2355
$filesize += length($outline) + 1;
2356
} # end loop copying lines
2357
$fmode[$cx] = $fmode & ($binmode|$browsemode);
2358
$fmode[$cx] |= $nlmode, --$filesize
2359
if $fmode&$nlmode and $endRange == $dol;
2360
} # nonempty file
2361
$map[$cx] = $mapcx;
2362
$dot[$cx] = $dol[$cx] = $dolcx;
2363
$factive[$cx] = 1;
2364
$fname[$cx] = "";
2365
$btags[$cx] = $btags;
2366
return 1;
2367
} # writeContext
2368
2369
# Move or copy a block of text.
2370
sub moveCopy()
2371
{
2372
$dest++; # more convenient
2373
$endr1 = $endRange+1; # more convenient
2374
$dest <= $startRange or
2375
$dest >= $endr1 or
2376
$errorMsg = "destination lies inside the block to be moved or copied", return 0;
2377
if($cmd eq 'm' and
2378
($dest == $endr1 or $dest == $startRange)) {
2379
$errorMsg = "no change" if ! $inglob;
2380
return 0;
2381
}
2382
my $starti = $startRange*$lnwidth;
2383
my $endi = $endr1*$lnwidth;
2384
my $desti = $dest * $lnwidth;
2385
my $offset = $endr1 - $startRange;
2386
my ($i, $j);
2387
# The section of the map that represents the range.
2388
my $piece_r = substr $map, $starti, $endi-$starti;
2389
my $piece_n = ""; # the new line numbers, if the text is copied.
2390
if($cmd eq 't') {
2391
return 0 if lineLimit $offset;
2392
for($j=0; $j<length($piece_r); $j+=$lnwidth) {
2393
push @text,
2394
$text[substr($piece_r, $j, $lnwidth1)];
2395
$piece_n .= sprintf $lnformat, $#text;
2396
}
2397
substr($map, $desti, 0) = $piece_n;
2398
} elsif($dest < $startRange) {
2399
substr($map, $starti, $endi-$starti) = "";
2400
substr($map, $desti, 0) = $piece_r;
2401
} else {
2402
substr($map, $desti, 0) = $piece_r;
2403
substr($map, $starti, $endi-$starti) = "";
2404
}
2405
if($fmode&$nlmode) {
2406
$fmode &= ~$nlmode if $dest > $dol;
2407
$fmode &= ~$nlmode if $endRange == $dol and $cmd eq 'm';
2408
}
2409
# Now for the labels
2410
my ($lowcut, $highcut, $p2len);
2411
if($dest <= $startRange) {
2412
$lowcut = $dest;
2413
$highcut = $endr1;
2414
$p2len = $startRange - $dest;
2415
} else {
2416
$lowcut = $startRange;
2417
$highcut = $dest;
2418
$p2len = $dest - $endr1;
2419
}
2420
foreach $i (0..25) {
2421
my $ln = substr($labels, $i*$lnwidth, $lnwidth); # line number
2422
next if $ln eq $lnspace or $ln < $lowcut;
2423
if($ln >= $highcut) {
2424
$ln += $offset if $cmd eq 't';
2425
} elsif($ln >= $startRange and $ln <= $endRange) {
2426
$ln += ($dest < $startRange ? -$p2len : $p2len) if $cmd eq 'm';
2427
$ln += $offset if $cmd eq 't' and $dest < $startRange;
2428
} elsif($dest < $startRange) {
2429
$ln += $offset;
2430
} else {
2431
$ln -= $offset if $cmd eq 'm';
2432
}
2433
substr($labels, $i*$lnwidth, $lnwidth) = sprintf $lnformat, $ln;
2434
} # loop over labels
2435
$dol += $offset if $cmd eq 't';
2436
$dot = $endRange;
2437
$dot += ($dest < $startRange ? -$p2len : $p2len) if $cmd eq 'm';
2438
$dot = $dest + $offset - 1 if $cmd eq 't';
2439
$fmode |= $changemode|$firstopmode;
2440
$ubackup = 1;
2441
return 1;
2442
} # moveCopy
2443
2444
# Delete a block of text.
2445
# Pass the range to delete.
2446
sub delText($$)
2447
{
2448
my ($sr, $er) = @_; # local start and end range
2449
my ($i, $j);
2450
$fmode &= ~$nlmode if $er == $dol;
2451
$j = $er - $sr + 1;
2452
substr($map, $sr*$lnwidth, $j*$lnwidth) = "";
2453
# Move the labels.
2454
foreach $i (0..25) {
2455
my $ln = substr($labels, $i*$lnwidth, $lnwidth); # line number
2456
next if $ln eq $lnspace or $ln < $sr;
2457
substr($labels, $i*$lnwidth, $lnwidth) =
2458
($ln <= $er ? $lnspace : (sprintf $lnformat, $ln - $j));
2459
} # loop over labels
2460
$dol -= $j;
2461
$dot = $sr;
2462
--$dot if $dot > $dol;
2463
$fmode |= $changemode|$firstopmode;
2464
$ubackup = 1;
2465
return 1;
2466
} # delText
2467
2468
# Delete files from a directory as you delete lines.
2469
# It actually moves them to your recycle bin.
2470
sub delFiles()
2471
{
2472
$dw or $errorMsg = "directories are readonly, type dw to enable directory writes", return 0;
2473
$dw == 2 or length $rbin or
2474
$errorMsg = "could not create .recycle under your home directory, to hold the deleted files", return 0;
2475
my $ln = $startRange;
2476
my $cnt = $endRange - $startRange + 1;
2477
while($cnt--) {
2478
my $f = fetchLine($ln, 0);
2479
if($dw == 2 or dirSuffix($ln) =~ /^@/) {
2480
unlink "$dirname/$f" or
2481
$errorMsg = "could not remove $f, $!", return 0;
2482
} else {
2483
rename "$dirname/$f", "$rbin/$f" or
2484
$errorMsg = "Could not move $f to the recycle bin, $!, set dx mode to actually remove the file", return 0;
2485
}
2486
delText($ln, $ln);
2487
substr($labels, $dirSufStart + 2*$ln, 2) = "";
2488
}
2489
return 1;
2490
} # delFiles
2491
2492
# Join lines from startRange to endRange.
2493
sub joinText()
2494
{
2495
$errorMsg = "cannot join one line", return 0 if $startRange == $endRange;
2496
return 0 if lineLimit 1;
2497
my ($i, $line);
2498
$line = "";
2499
foreach $i ($startRange..$endRange) {
2500
$line .= ' ' if $cmd eq 'J' and $i > $startRange;
2501
$line .= fetchLine($i, 0);
2502
}
2503
push @text, $line;
2504
substr($map, $startRange*$lnwidth, $lnwidth) = sprintf $lnformat, $#text;
2505
delText($startRange+1, $endRange);
2506
$dot = $startRange;
2507
return 1;
2508
} # joinText
2509
2510
# Substitute text on the lines in $startRange through $endRange.
2511
# We could be changing the text in an input field.
2512
# If so, we'll call infReplace().
2513
# Also, we might be indirectory mode, whence we must rename the file.
2514
sub substituteText($)
2515
{
2516
my $line = shift;
2517
my $whichlink = "";
2518
$whichlink = $1 if $line =~ s/^(\d+)//;
2519
length $line or
2520
$errorMsg = "no regular expression after $icmd", return -1;
2521
if($fmode&$dirmode) {
2522
$dw or $errorMsg = "directories are readonly, type dw to enable directory writes", return -1;
2523
}
2524
my ($i, $j, $exp, $rhs, $qrhs, $lastSubst, @pieces, $blmode);
2525
2526
if($line ne "bl") {
2527
$blmode = 0;
2528
@pieces = regexpCheck($line, 1);
2529
return -1 if $#pieces < 0;
2530
$exp = $pieces[0];
2531
$line = $pieces[1];
2532
length $line or $errorMsg = "missing delimiter", return -1;
2533
@pieces = regexpCheck($line, 0);
2534
return -1 if $#pieces < 0;
2535
$rhs = $pieces[0];
2536
$line = $pieces[1];
2537
} else { $blmode = 1, $lspace = 3; }
2538
2539
my $gflag = "";
2540
my $nflag = 0;
2541
my $iflag = "";
2542
$iflag = "i" if $caseInsensitive;
2543
$subprint = 1; # default is to print the last line substituted
2544
$lastSubst = 0;
2545
2546
if(! $blmode) {
2547
if(length $line) {
2548
$subprint = 0;
2549
# necessarily starts with the delimiter
2550
substr($line, 0, 1) = "";
2551
while(length $line) {
2552
$gflag = 'g', next if $line =~ s/^g//;
2553
$subprint = 2, next if $line =~ s/^p//;
2554
$iflag = 'i', next if $line =~ s/^i//;
2555
if($line =~ s/^(\d+)//) {
2556
! $nflag or $errorMsg = "multiple numbers after the third delimiter", return -1;
2557
$nflag = $1;
2558
$nflag > 0 and $nflag <= 999 or
2559
$errorMsg = "numeric suffix out of range, please use [1-999]", return -1;
2560
next;
2561
} # number
2562
$errorMsg = "unexpected substitution suffix after the third delimiter";
2563
return -1;
2564
} # loop gathering suffix flags
2565
! $gflag or ! $nflag or
2566
$errorMsg = "cannot use both a numeric suffix and the `g' suffix simultaneously", return -1;
2567
# s/x/y/1 is very inefficient.
2568
$nflag = 0 if $nflag == 1;
2569
} # closing delimiter
2570
2571
$qrhs = $rhs; # quote-fixed right hand side
2572
if($rhs =~ /^[ul]c$/) {
2573
$qrhs = "$qrhs \$&";
2574
$iflag .= 'e' if !$nflag;
2575
} elsif($rhs eq "mc") {
2576
$qrhs = "mixCase \$&";
2577
$iflag .= 'e' if !$nflag;
2578
} else {
2579
if($nflag) {
2580
$qrhs =~ s/"/\\"/g;
2581
$qrhs = '"'.$qrhs.'"';
2582
}
2583
}
2584
2585
# I don't understand it, but $&[x] means something to perl.
2586
# So when I replace j with &[x], becomeing $&[x], it blows up.
2587
# Thus I escape open brackets and braces in the rhs.
2588
# Hopefully you won't escape them on the command line - you have no reason to.
2589
# If you do they'll be doubly escaped, and that's bad.
2590
$qrhs =~ s/([\[{])/\\$1/g; # }
2591
} else {
2592
$subprint = 0;
2593
} # blmode or not
2594
2595
# Substitute the input fields first.
2596
if($cmd eq 'I') {
2597
my $yesdot = 0;
2598
my $foundFields = 0;
2599
foreach $i ($startRange..$endRange) {
2600
my $rc = infIndex($i, $whichlink);
2601
next unless $rc;
2602
$foundFields = 1;
2603
$rc > 0 or $dot = $i, $inglob = 0, return -1;
2604
my $newinf = $inf;
2605
if(!$nflag) {
2606
eval '$rc = $newinf =~ ' .
2607
"s/$exp/$qrhs/$iflag$gflag; ";
2608
} else {
2609
$j = 0;
2610
eval '$newinf =~ ' .
2611
"s/$exp/++\$j == $nflag ? $qrhs : \$&/ge$iflag; ";
2612
$rc = ($j >= $nflag);
2613
}
2614
next unless $rc;
2615
$dot = $i;
2616
infReplace($newinf) or return -1;
2617
$yesdot = $dot;
2618
} # loop over lines
2619
if(! $yesdot) {
2620
if(!$inglob) {
2621
$errorMsg = "no match" if $foundFields;
2622
}
2623
return 0;
2624
}
2625
dispLine($yesdot) if $subprint == 2 or ! $inglob and $subprint == 1;
2626
return 1;
2627
} # input fields
2628
2629
# Not an input field, just text, so replace it.
2630
# Once again, use the eval construct.
2631
# This time we might be substituting across an entire range.
2632
@pieces = ();
2633
$errorMsg = "";
2634
eval '
2635
for($i=$startRange; $i<=$endRange; ++$i) {
2636
my $temp = fetchLine($i, 0);' .
2637
($blmode ? 'my $subst = breakLine(\$temp);' :
2638
(!$nflag ?
2639
'my $subst = $temp =~ ' .
2640
"s/$exp/$qrhs/o$iflag$gflag; "
2641
:
2642
'my $subst = 0;
2643
my $k = 0;
2644
$temp =~ ' .
2645
"s/$exp/++\$k == $nflag ? $qrhs : \$&/oge$iflag; " .
2646
'$subst = ($k >= $nflag); '
2647
)) .
2648
'next unless $subst;
2649
if($fmode&$dirmode) {
2650
if($temp =~ m,[/\n],) {
2651
$errorMsg = "cannot embed slash or newline in a directory name";
2652
$inglob = 0;
2653
last;
2654
}
2655
my $dest = "$dirname/$temp";
2656
my $src = fetchLine($i, 0);
2657
$src = "$dirname/$src";
2658
if($src ne $dest) {
2659
if(-e $dest or -l $dest) {
2660
$errorMsg = "destination file already exists";
2661
$inglob = 0;
2662
last;
2663
}
2664
rename $src, $dest or
2665
$errorMsg = "cannot move file to $temp", $inglob = 0, last;
2666
} # source and dest are different
2667
} # directory
2668
@pieces = split "\n", $temp, -1;
2669
@pieces = ("") if $temp eq "";
2670
last if lineLimit $#pieces+1;
2671
$j = $#text;
2672
push @text, @pieces;
2673
@pieces = ();
2674
substr($map, $i*$lnwidth, $lnwidth) = sprintf $lnformat, ++$j;
2675
if($j < $#text) {
2676
my $newpiece = "";
2677
$newpiece .= sprintf $lnformat, $j while ++$j <= $#text;
2678
addToMap($newpiece, $i);
2679
$j = length($newpiece) / $lnwidth;
2680
$endRange += $j;
2681
$i += $j;
2682
}
2683
dispLine($i) if $subprint == 2;
2684
$lastSubst = $i;
2685
$fmode |= $changemode|$firstopmode;
2686
$ubackup = 1;
2687
last if $intFlag;
2688
}
2689
'; # eval string
2690
return 0 if length $errorMsg;
2691
if(! $lastSubst) {
2692
$errorMsg = ($blmode ? "no change" : "no match") if ! $inglob;
2693
return 0;
2694
}
2695
$dot = $lastSubst;
2696
dispLine($dot) if $subprint == 1 and ! $inglob;
2697
if($intFlag and ! $inglob) {
2698
$errorMsg = $intMsg, return 0;
2699
}
2700
return 1;
2701
} # substituteText
2702
2703
# Follow a hyperlink to another web page.
2704
sub hyperlink($)
2705
{
2706
my $whichlink = shift;
2707
$cmd = 'b';
2708
$errorMsg = "cannot use the g$whichlink command in directory mode", return 0 if $fmode&$dirmode;
2709
$startRange == $endRange or
2710
$errorMsg = "go command does not expect a range", return 0;
2711
2712
my $h; # hyperlink tag
2713
my @links = (); # links on this line
2714
my @bref = (); # baseref values
2715
my ($j, $line, $href);
2716
2717
if($fmode&$browsemode) {
2718
$line = fetchLine $endRange, 0;
2719
while($line =~ /\x80([\x85-\x8f]+){/g) {
2720
$j = revealNumber $1;
2721
$h = $$btags[$j];
2722
$href = $$h{href};
2723
$errorMsg = "hyperlink found without a url?? internal error", return 0 unless defined $href;
2724
push @links, $href;
2725
push @bref, $$h{bref};
2726
} # loop
2727
} # browse mode
2728
2729
if($#links < 0) {
2730
$line = fetchLine $endRange, 1;
2731
stripWhite \$line;
2732
$line =~ s/[\s"']+/ /g;
2733
if(length $line) {
2734
while($line =~ /([^ ]+)/g) {
2735
$href = $1;
2736
$href =~ s/^[^\w]+//;
2737
$href =~ s/[^\w]+$//;
2738
if(is_url $href) {
2739
push @links, $href;
2740
} else {
2741
$href =~ s/^mailto://i;
2742
push @links, "mailto:$href" if $href =~ /^[\w.,-]+@[\w,-]+\.[\w,.-]+$/;
2743
}
2744
}
2745
} # loop over words
2746
} # looking for url in text mode
2747
2748
$j = $#links + 1;
2749
$j or $errorMsg = "no links present", return 0;
2750
length $whichlink or $j == 1 or
2751
$errorMsg = "multiple links, please use g [1,$j]", return 0;
2752
$whichlink = 1 if ! length $whichlink;
2753
if($whichlink == 0 or $whichlink > $j) {
2754
$errorMsg = $j > 1 ?
2755
"invalid link, please use g [1,$j]" :
2756
"this line only has one link";
2757
return 0;
2758
}
2759
--$whichlink;
2760
$href = $links[$whichlink];
2761
if($href =~ s/^mailto://i) {
2762
$cmd = 'e';
2763
return 1, "\x80mail\x80$href";
2764
} # mailto
2765
$href =~ /^javascript:/i and
2766
$errorMsg = "sorry, this link calls a javascript function", return 0;
2767
return 1, $href if $href =~ /^#/;
2768
$line = resolveUrl(($#bref >= 0 ? $bref[$whichlink] : ""), $href);
2769
print "* $line\n";
2770
return 1, $line;
2771
} # hyperlink
2772
2773
# Follow an internal link to a section of the document.
2774
sub findSection($)
2775
{
2776
my $section = shift;
2777
foreach my $i (1..$dol) {
2778
my $t = fetchLine $i, 0;
2779
while($t =~ /\x80([\x85-\x8f]+)\*/g) {
2780
my $j = revealNumber $1;
2781
my $h = $$btags[$j];
2782
return $i if $$h{name} eq $section;
2783
}
2784
}
2785
return 0;
2786
} # findSection
2787
2788
# Return the number of unbalanced punctuation marks at the start and end of the line.
2789
sub unbalanced($$$)
2790
{
2791
my ($c, $d, $ln) = @_;
2792
my $curline = fetchLine($ln, 1);
2793
# Escape these characters, so we know they are literal.
2794
$c = "\\$c";
2795
$d = "\\$d";
2796
while($curline =~ s/$c[^$c$d]*$d//) { ; }
2797
my $forward = $curline =~ s/$c//g;
2798
$forward = 0 if $forward eq "";
2799
my $backward = $curline =~ s/$d//g;
2800
$backward = 0 if $backward eq "";
2801
return $backward, $forward;
2802
} # unbalanced
2803
2804
# Find the line that balances the unbalanced punctuation.
2805
sub balanceLine($)
2806
{
2807
my $line = shift;
2808
my ($c, $d); # balancing characters
2809
my $openlist = "{([<`";
2810
my $closelist = "})]>'";
2811
my $alllist = "{}()[]<>`'";
2812
my $level = 0;
2813
my ($i, $direction, $forward, $backward);
2814
2815
if(length $line) {
2816
$line =~ /^[\{\}\(\)\[\]<>`']$/ or
2817
$errorMsg = "you must specify exactly one of $alllist after the B command", return 0;
2818
$c = $line;
2819
if(index($openlist, $c) >= 0) {
2820
$d = substr $closelist, index($openlist, $c), 1;
2821
$direction = 1;
2822
} else {
2823
$d = $c;
2824
$c = substr $openlist, index($closelist, $d), 1;
2825
$direction = -1;
2826
}
2827
($backward, $forward) = unbalanced($c, $d, $endRange);
2828
if($direction > 0) {
2829
($level = $forward) or
2830
$errorMsg = "line does not contain an open $c", return 0;
2831
} else {
2832
($level = $backward) or
2833
$errorMsg = "line does not contain an open $d", return 0;
2834
}
2835
} else { # character specified by the user or not?
2836
# Look for anything unbalanced, probably a brace.
2837
foreach $i (0..2) {
2838
$c = substr $openlist, $i, 1;
2839
$d = substr $closelist, $i, 1;
2840
($backward, $forward) = unbalanced($c, $d, $endRange);
2841
! $backward or ! $forward or
2842
$errorMsg = "both $c and $d are unbalanced on this line, try B$c or B$d", return 0;
2843
($level = $backward + $forward) or next;
2844
$direction = 1;
2845
$direction = -1 if $backward;
2846
last;
2847
}
2848
$level or
2849
$errorMsg = "line does not contain an unbalanced brace, parenthesis, or bracket", return 0;
2850
} # explicit character passed in, or look for one
2851
2852
my $selected = ($direction > 0) ? $c : $d;
2853
2854
# Now search for the balancing line.
2855
$i = $endRange;
2856
while(($i += $direction) > 0 and $i <= $dol) {
2857
($backward, $forward) = unbalanced($c, $d, $i);
2858
if($direction > 0 and $backward >= $level or
2859
$direction < 0 and $forward >= $level) {
2860
$dot = $i;
2861
dispLine($dot);
2862
return 1;
2863
}
2864
$level += ($forward-$backward) * $direction;
2865
} # loop over lines
2866
2867
$errorMsg = "cannot find the line that balances $selected";
2868
return 0;
2869
} # balanceLine
2870
2871
# Apply a regular expression to each line, and then execute
2872
# a command for each matching, or nonmatching, line.
2873
# This is the global feature, g/re/p, which gives us the word grep.
2874
sub doGlobal($)
2875
{
2876
my $line = shift;
2877
my ($i, $j, $exp, @pieces);
2878
2879
length $line or
2880
$errorMsg = "no regular expression after $icmd", return 0;
2881
@pieces = regexpCheck($line, 1);
2882
return 0 if $#pieces < 0;
2883
$exp = $pieces[0];
2884
$line = $pieces[1];
2885
length $line or
2886
$errorMsg = "missing delimiter", return 0;
2887
$line =~ s/^.(i?)\s*//;
2888
my $iflag = $1;
2889
$iflag = "i" if $caseInsensitive;
2890
2891
# Clean up any previous stars.
2892
substr($map, $_*$lnwidth+$lnwidth1, 1) = ' ' foreach (1.. $dol);
2893
2894
# Find the lines that match the pattern.
2895
my $gcnt = 0; # global count
2896
eval '
2897
for($i=$startRange, $j=$i*$lnwidth+$lnwidth1; $i<=$endRange; ++$i, $j+=$lnwidth) {
2898
substr($map, $j, 1) = "*", ++$gcnt if
2899
fetchLine($i, 1)' .
2900
($cmd eq 'g' ? ' =~ ' : ' !~ ') .
2901
"/$exp/o$iflag; }";
2902
$gcnt or $errorMsg =
2903
($cmd eq 'g' ? "no lines match the g pattern" : "all lines match the v pattern"),
2904
return 0;
2905
2906
# Now apply $line to every line with a *
2907
$inglob = 1;
2908
$errorMsg = "";
2909
$line = 'p' if ! length $line;
2910
my $origdot = $dot;
2911
my $yesdot = 0;
2912
my $nodot = 0;
2913
my $stars = 1;
2914
global:while($gcnt and $stars) {
2915
$stars = 0;
2916
for($i=1; $i<=$dol; ++$i) {
2917
last global if $intFlag;
2918
next unless substr($map, $i*$lnwidth+$lnwidth1, 1) eq '*';
2919
$stars = 1,--$gcnt;
2920
substr($map, $i*$lnwidth+$lnwidth1, 1) = ' ';
2921
$dot = $i; # ready to run the command
2922
if(evaluate($line)) {
2923
$yesdot = $dot;
2924
--$i if $ubackup; # try this line again, in case we deleted or moved it
2925
} else {
2926
# Subcommand might turn global flag off.
2927
$nodot = $dot, $yesdot = 0, last global if ! $inglob;
2928
}
2929
}
2930
}
2931
$inglob = 0;
2932
# yesdot could be 0, even upon success, if all lines are deleted via g/re/d
2933
if($yesdot or ! $dol) {
2934
$dot = $yesdot;
2935
dispLine($dot) if ($cmd eq 's' or $cmd eq 'I') and $subprint == 1;
2936
} elsif($nodot) {
2937
$dot = $nodot;
2938
} else {
2939
$dot = $origdot;
2940
$errorMsg = "none of the marked lines were successfully modified" if $errorMsg eq "";
2941
}
2942
$errorMsg = $intMsg if $errorMsg eq "" and $intFlag;
2943
return ! length $errorMsg;
2944
} # doGlobal
2945
2946
# Reveal the links to other web pages, or the email links.
2947
sub showLinks()
2948
{
2949
my ($i, $j, $h, $href, $line);
2950
my $addrtext = "";
2951
if($fmode&$browsemode) {
2952
$line = fetchLine $endRange, 0;
2953
while($line =~ /\x80([\x85-\x8f]+){(.*?)}/g) {
2954
$j = revealNumber $1;
2955
$i = $2;
2956
$h = $$btags[$j];
2957
$href = $$h{href};
2958
$href = "" unless defined $href;
2959
if($href =~ s/^mailto://i) {
2960
$addrtext .= "$i:$href\n";
2961
} else {
2962
$href = resolveUrl($$h{bref}, $href);
2963
$addrtext .= "<A HREF=$href>\n$i\n</A>\n";
2964
}
2965
} # loop
2966
} # browse mode
2967
if(! length $addrtext) {
2968
length $fname or $errorMsg = "no file name", return 0;
2969
if(is_url($fname)) {
2970
$href = $fname;
2971
$href =~ s/\.browse$//;
2972
$j = $href;
2973
$j =~ s,^https?://,,i;
2974
$j =~ s,.*/,,;
2975
$addrtext = "<A HREF=$href>\n$j\n</A>\n";
2976
} else {
2977
$addrtext = $fname."\n";
2978
}
2979
}
2980
$addrtext =~ s/\n$//;
2981
$j = $#text;
2982
push @text, split "\n", $addrtext, -1;
2983
$#text = $j, return 0 if lineLimit 0;
2984
$h = cxPack();
2985
cxReset($context, 0) or return 0;
2986
$$h{backup} = $backup if defined $backup;
2987
$backup = $h;
2988
print((length($addrtext)+1)."\n");
2989
$dot = $dol = $#text - $j;
2990
my $newpiece = $lnspace;
2991
$newpiece .= sprintf($lnformat, $j) while ++$j <= $#text;
2992
$map = $newpiece;
2993
return 1;
2994
} # showLinks
2995
2996
# All other editors let you stack and undo hundreds of operations.
2997
# If I'm writing a new editor, why don't I do that?
2998
# I don't know; guess I don't have the time.
2999
# And in my 20 years experience, I have rarely felt the need
3000
# to undo several operations.
3001
# I'm usually undoing the last typo, and that's it.
3002
# So I allow you to undo the last operation, only.
3003
# Get ready for a possible undo command.
3004
sub readyUndo()
3005
{
3006
return if $fmode & $dirmode;
3007
$savedot = $dot, $savedol = $dol;
3008
$savemap = $map, $savelabels = $labels;
3009
} # readyUndo
3010
3011
sub goUndo()
3012
{
3013
# swap, so we can undo our undo. I do this alot.
3014
my $temp;
3015
$temp = $ dot, $dot = $lastdot, $lastdot = $temp;
3016
$temp = $ dol, $dol = $lastdol, $lastdol = $temp;
3017
$temp = $ map, $map = $lastmap, $lastmap = $temp;
3018
$temp = $ labels, $labels = $lastlabels, $lastlabels = $temp;
3019
} # goUndo
3020
3021
# Replace labels with their lines in shell escapes.
3022
sub expandLabeledLine($)
3023
{
3024
my$x = shift;
3025
my $n = ord($x) - ord('a');
3026
my $ln = substr $labels, $n*$lnwidth, $lnwidth;
3027
$ln ne $lnspace or
3028
$errorMsg = "label $x not set", return "";
3029
return fetchLine($ln, 1);
3030
} # expandLabeledLine
3031
3032
# Run a shell escape
3033
sub shellEscape($)
3034
{
3035
my $line = shift;
3036
# Expand 'a through 'z labels
3037
$errorMsg = "";
3038
$line =~ s/\B'([a-z])\b/expandLabeledLine($1)/ge;
3039
return 0 if length $errorMsg;
3040
$line =~ s/'_/$fname/g;
3041
$line =~ s/'\./fetchLine($dot,1)/ge;
3042
if($doslike) {
3043
# Just run system and hope for the best.
3044
system $line;
3045
} else {
3046
# Unix has a concept of shells.
3047
my $shell = $ENV{SHELL};
3048
$shell = "/bin/sh" if ! defined $shell;
3049
if(length $line) {
3050
system $shell, "-c", $line;
3051
} else {
3052
system $shell;
3053
}
3054
} # dos or unix
3055
print "ok\n";
3056
return 1;
3057
} # shellEscape
3058
3059
# Implement various two letter commands.
3060
# Most of these set and clear modes.
3061
sub twoLetter($)
3062
{
3063
my $line = shift;
3064
my ($i, $j);
3065
3066
if($line eq "qt") { exit 0; }
3067
3068
if($line =~ s/^cd\s+// or $line =~ s/^cd$//) {
3069
$cmd = 'e'; # so error messages are printed
3070
if(length $line) {
3071
my $temppath = `pwd`;
3072
chomp $temppath;
3073
if($line eq "-") {
3074
$errorMsg = "you have no previous directory", return 0 unless defined $oldpath;
3075
chdir $oldpath or $errorMsg = "cannot change to previous directory $oldpath", return 0;
3076
} else {
3077
$line = envFile($line);
3078
return 0 if length $errorMsg;
3079
chdir $line or $errorMsg = "invalid directory", return 0;
3080
}
3081
$oldpath = $temppath;
3082
}
3083
print `pwd`;
3084
return 1;
3085
}
3086
3087
if($line eq "rf") {
3088
$cmd = 'e';
3089
if($fmode & $browsemode) {
3090
$cmd = 'b';
3091
$fname =~ s/.browse$//;
3092
}
3093
length $fname or $errorMsg = "no file name", return 0;
3094
$nostack = 1;
3095
return -1, "$cmd $fname";
3096
}
3097
3098
if($line eq "et") {
3099
$cmd = 'e';
3100
$fmode&$browsemode or
3101
$errorMsg = $nobrowse, return 0;
3102
foreach $i (1..$dol) {
3103
$text[substr($map, $i*$lnwidth, $lnwidth1)] = fetchLine($i,1);
3104
}
3105
$fmode &= ~($browsemode|$firstopmode|$changemode);
3106
$btags = []; # don't need those any more.
3107
print "editing as pure text\n" if $helpall;
3108
return 1;
3109
}
3110
3111
if($line eq "ub") {
3112
$fmode&$browsemode or
3113
$errorMsg = $nobrowse, return 0;
3114
dropEmptyBuffers();
3115
# Backing out.
3116
$map = $$btags[0]{map1};
3117
$fname = $$btags[0]{fname};
3118
$fmode = $$btags[0]{fmode};
3119
$labels = $$btags[0]{labels};
3120
$dot = $$btags[0]{dot};
3121
$dol = $$btags[0]{dol1};
3122
apparentSize();
3123
return 1;
3124
} # reverse browse
3125
3126
if($line eq "f/" or $line eq "w/") {
3127
$i = $fname;
3128
$i =~ s,.*/,, or
3129
$errorMsg = "filename does not contain a slash", return 0;
3130
print "$i\n" if $helpall;
3131
substr($line, 1, 1) = " $i";
3132
return -1, $line;
3133
}
3134
3135
if($line =~ /^f[dkt]$/) {
3136
$fmode&$browsemode or
3137
$errorMsg = $nobrowse, return 0;
3138
my $key = "title";
3139
$key = "keywords" if $line eq "fk";
3140
$key = "description" if $line eq "fd";
3141
my $val = $$btags[0]{$key};
3142
if(defined $val) {
3143
print "$val\n";
3144
} else {
3145
print "no $key\n";
3146
}
3147
return 1;
3148
}
3149
3150
if($line =~ /^sm(\d*)$/) {
3151
$cmd = 'e';
3152
$smMail = $1;
3153
$altattach = 0;
3154
$j = sendMailCurrent();
3155
$j and print "ok\n";
3156
return $j;
3157
}
3158
3159
# simple commands
3160
if($line eq "sg") { $global_lhs_rhs = 1; print "substitutions global\n" if $helpall; return 1; }
3161
if($line eq "sl") { $global_lhs_rhs = 0; print "substitutions local\n" if $helpall; return 1; }
3162
if($line eq "ci") { $caseInsensitive = 1; print "case insensitive\n" if $helpall; return 1; }
3163
if($line eq "cs") { $caseInsensitive = 0; print "case sensitive\n" if $helpall; return 1; }
3164
if($line eq "dr") { $dw = 0; print "directories readonly\n" if $helpall; return 1; }
3165
if($line eq "dw") { $dw = 1; print "directories writable\n" if $helpall; return 1; }
3166
if($line eq "dx") { $dw = 2; print "directories writable with delete\n" if $helpall; return 1; }
3167
if($line eq "dp") { $delprint ^= 1; print ($delprint ? "delete print\n" : "delete quiet\n"); return 1; }
3168
if($line eq "rh") { $reroute ^= 1; print ($reroute ? "redirect html\n" : "do not redirect html\n"); return 1; }
3169
if($line eq "pm") { $passive ^= 1; print ($passive ? "passive ftp\n" : "active ftp\n"); return 1; }
3170
if($line eq "ph") { $pdf_convert ^= 1; print ($pdf_convert ? "pdf to html conversion\n" : "pdf raw\n"); return 1; }
3171
if($line eq "vs") { $ssl_verify ^= 1; print ($ssl_verify ? "verify ssl connections\n" : "do not verify ssl connections (less secure)\n"); return 1; }
3172
if($line eq "ac") { $allowCookies ^= 1; print ($allowCookies ? "accept cookies\n" : "reject cookies\n"); return 1; }
3173
if($line eq "sr") { $allowReferer ^= 1; print ($allowReferer ? "send refering web page\n" : "don't send refering web page\n"); return 1; }
3174
if($line =~ s/^db *//) {
3175
if($line =~ /^\d$/) {
3176
$debug = $line, return 1;
3177
} else {
3178
$errorMsg = "please set debug level, 0 through 7", return 0;
3179
}
3180
}
3181
if($line =~ s/^ua *//) {
3182
if($line =~ /^\d+$/) {
3183
$errorMsg = "Agent number $line is not defined", return 0 if ! defined$agents[$line];
3184
$agent = $agents[$line], return 1;
3185
} else {
3186
$errorMsg = "please set user agent, 0 through ".$#agents, return 0;
3187
}
3188
} # ua number
3189
if($line eq "ff") { $fetchFrames ^= 1; print ($fetchFrames ? "fetch frames\n" : "do not fetch frames\n"); return 1; }
3190
if($line eq "tn") { $textAreaCR ^= 1; print ($textAreaCR ? "dos newlines on text areas\n" : "unix newlines on text areas\n"); return 1; }
3191
if($line eq "eo") { $endmarks = 0; print "end markers off\n" if $helpall; return 1; }
3192
if($line eq "el") { $endmarks = 1; print "end markers list\n" if $helpall; return 1; }
3193
if($line eq "ep") { $endmarks = 2; print "end markers on\n" if $helpall; return 1; }
3194
return -1,"^".length($1) if $line =~ /^(\^+)$/;
3195
return stripChild() if $line eq "ws";
3196
return unstripChild() if $line eq "us";
3197
3198
return -1, $line; # no change
3199
} # twoLetter
3200
3201
# Evaluate the entered command.
3202
# This is indirectly recursive, as in g/z/ s/x/y/
3203
# Pass the command line, and return success or failure.
3204
sub evaluate($)
3205
{
3206
my $line = shift;
3207
my ($i, $j, @pieces, $h, $href);
3208
my $postspace = 0;
3209
my $postBrowse;
3210
my $nsuf = -1; # numeric suffix
3211
my $cx; # context specified -- always $nsuf - 1
3212
my $section = ""; # section within a document
3213
my $post = ""; # for post cgi method
3214
$nostack = 0; # suppress stacking of edit sessions
3215
3216
$referer = "";
3217
$referer = $fname if $allowReferer;
3218
$referer =~ s/\.browse$//;
3219
3220
$cmd = "";
3221
# We'll allow whitespace at the start of an entered command.
3222
$line =~ s/^\s*//;
3223
# Watch for successive q commands.
3224
$lastq = $lastqq, $lastqq = -1;
3225
3226
if(!$inglob) {
3227
# We'll allow comments in an edbrowse script
3228
return 1 if $line =~ /^#/;
3229
3230
return shellEscape $line if $line =~ s/^!\s*//;
3231
3232
# Web express shortcuts
3233
if($line =~ s/^@ *//) {
3234
if(! length $line) {
3235
my @shortList = ();
3236
foreach $i (sort keys %shortcut) {
3237
$j = $i;
3238
my ($desc, $sort);
3239
defined ($desc = $shortcut{$i}{desc}) and
3240
$j .= " = $desc";
3241
$j = "|$j";
3242
defined ($sort = $shortcut{$i}{sort}) and
3243
$j = "$sort$j";
3244
$j .= "\n";
3245
push @shortList, $j;
3246
} # loop over shortcuts
3247
foreach (sort @shortList) {
3248
s/^.*?\|//;
3249
print $_;
3250
}
3251
return 1;
3252
}
3253
$cmd = '@';
3254
($j, $line, $postBrowse) = webExpress($line);
3255
return 0 unless $j;
3256
$line =~ s%^%b http://%;
3257
if($line =~ /\*/) {
3258
$post = $line;
3259
$post =~ s/.*\*/*/;
3260
$line =~ s/\*.*//;
3261
}
3262
}
3263
3264
# Predefined command sets.
3265
if($line =~ s/^< *//) {
3266
if(!length $line) {
3267
foreach $i (sort keys %commandList) {
3268
print "$i\n";
3269
}
3270
return 1;
3271
}
3272
$i = $commandList{$line};
3273
defined $i or $errorMsg = "command set $line is not recognized", return 0;
3274
return evaluateSequence($i, $commandCheck{$line});
3275
} # command set
3276
3277
# Two letter commands.
3278
($j, $line) = twoLetter($line);
3279
return $j if $j >= 0;
3280
} # not in global
3281
3282
$startRange = $endRange = $dot; # default, if no range given
3283
$line = '+' if ! length $line;
3284
$line = ($dol ? 1 : 0) . $line if substr($line, 0, 1) eq ',';
3285
if($line =~ /^j/i) {
3286
$endRange = $dot + 1;
3287
$errorMsg = "line number too large", return "" if $endRange > $dol;
3288
} elsif(substr($line, 0, 1) eq '=') {
3289
$startRange = $endRange = $dol;
3290
} elsif($line =~ /^[wgv]/ and $line !~ /^g\s*\d*$/) {
3291
$startRange = 1, $endRange = $dol;
3292
$startRange = 0 if ! $dol;
3293
} elsif($line =~ s/^;//) {
3294
$endRange = $dol;
3295
} else {
3296
@pieces = getRangePart($line);
3297
$inglob = 0, return 0 if $#pieces < 0;
3298
$startRange = $endRange = $pieces[0];
3299
$line = $pieces[1];
3300
if($line =~ s/^,//) {
3301
$endRange = $dol; # new default
3302
if($line =~ /^[-'.\$+\d\/?]/) {
3303
@pieces = getRangePart($line);
3304
$inglob = 0, return 0 if $#pieces < 0;
3305
$endRange = $pieces[0];
3306
$line = $pieces[1];
3307
} # second address
3308
} # comma present
3309
} # end standard range processing
3310
3311
# lc lower case, uc upper case
3312
$line =~ s:^([lmu]c)$:s/.*/$1/:;
3313
if($line eq "bl") { # break the line
3314
dirBrowseCheck("break line") or return 0;
3315
$line = "sbl";
3316
}
3317
3318
$cmd = substr($line, 0, 1);
3319
if(length $cmd) { $line = substr($line, 1); } else { $cmd = 'p'; }
3320
$icmd = $cmd;
3321
$startRange <= $endRange or
3322
$errorMsg = "bad range", return 0;
3323
index($valid_cmd, $cmd) >= 0 or
3324
$errorMsg = "unknown command $cmd", $inglob = 0, return 0;
3325
3326
# Change some of the command codes, depending on context
3327
$cmd = 'I' if $cmd eq 'i' and $line =~ /^[$valid_delim\d<*]/o;
3328
$cmd = 'I' if $cmd eq 's' and $fmode&$browsemode;
3329
$cmd = 's' if $cmd eq 'S';
3330
my $writeMode = ">";
3331
if($cmd eq "w" and substr($line, 0, 1) eq "+") {
3332
$writeMode = ">>";
3333
$line =~ s/^.//;
3334
}
3335
3336
!($fmode&$dirmode) or index($dir_cmd, $cmd) >= 0 or
3337
$errorMsg = "$icmd $nixdir", $inglob = 0, return 0;
3338
!($fmode&$browsemode) or index($browse_cmd, $cmd) >= 0 or
3339
$errorMsg = "$icmd $nixbrowse", $inglob = 0, return 0;
3340
$startRange > 0 or index($zero_cmd, $cmd) >= 0 or
3341
$errorMsg = "zero line number", return 0;
3342
$postspace = 1 if $line =~ s/^\s+//;
3343
if(index($spaceplus_cmd, $cmd) >= 0 and
3344
! $postspace and length $line and
3345
$line !~ /^\d+$/) {
3346
$errorMsg = "no space after command";
3347
return 0;
3348
}
3349
3350
# env variable and wild card expansion
3351
if(index("brewf", $cmd) >= 0 and length $line) {
3352
$line = envFile($line);
3353
return 0 if length $errorMsg;
3354
}
3355
3356
if($cmd eq 'B') {
3357
return balanceLine($line);
3358
}
3359
3360
if($cmd eq 'z') {
3361
$startRange = $endRange + 1;
3362
$endRange = $startRange;
3363
$startRange <= $dol or
3364
$errorMsg = "line number too large", return 0;
3365
$cmd = 'p';
3366
$line = $last_z if ! length $line;
3367
if($line =~ /^(\d+)\s*$/) {
3368
$last_z = $1;
3369
$last_z = 1 if $last_z == 0;
3370
$endRange += $last_z - 1;
3371
$endRange = $dol if $endRange > $dol;
3372
} else {
3373
$errorMsg = "z command should be followed by a number", return 0;
3374
}
3375
$line = "";
3376
}
3377
3378
# move/copy destination, the third address
3379
if($cmd eq 'm' or $cmd eq 't') {
3380
length $line or
3381
$errorMsg = "no move/copy destination", $inglob = 0, return 0;
3382
$line =~ /^[-'.\$+\d\/?]/ or
3383
$errorMsg = "invalid move/copy destination", $inglob = 0, return 0;
3384
@pieces = getRangePart($line);
3385
$inglob = 0, return 0 if $#pieces < 0;
3386
$dest = $pieces[0];
3387
$line = $pieces[1];
3388
$line =~ s/^\s*//;
3389
} # move copy destination
3390
if($cmd eq 'a') {
3391
($line eq "+") ? ($line = "") : ($linePending = undef);
3392
} else {
3393
$linePending = undef;
3394
}
3395
! length $line or index($nofollow_cmd, $cmd) < 0 or
3396
$errorMsg = "unexpected text after the $icmd command", $inglob = 0, return 0;
3397
3398
# We don't need trailing whitespace, except for substitute or global substitute.
3399
index("sgvI", $cmd) >= 0 or
3400
$line =~ s/\s*$//;
3401
3402
! $inglob or
3403
index($global_cmd, $cmd) >= 0 or
3404
$errorMsg = "the $icmd command cannot be applied globally", $inglob = 0, return 0;
3405
3406
if($cmd eq 'h') {
3407
$errorMsg = "no errors" if ! length $errorMsg;
3408
print $errorMsg,"\n";
3409
return 1;
3410
}
3411
3412
if($cmd eq 'H') {
3413
$helpall ^= 1;
3414
print "help messages on\n" if $helpall;
3415
return 1;
3416
} # H
3417
3418
if(index("lpn", $cmd) >= 0) {
3419
foreach $i ($startRange..$endRange) {
3420
dispLine($i);
3421
$dot = $i;
3422
last if $intFlag;
3423
}
3424
return 1;
3425
}
3426
3427
if($cmd eq '=') {
3428
print $endRange,"\n";
3429
return 1;
3430
}
3431
3432
if($cmd eq 'u') {
3433
$fmode&$firstopmode or
3434
$errorMsg = "nothing to undo", return 0;
3435
goUndo();
3436
return 1;
3437
} # u
3438
3439
if($cmd eq 'k') {
3440
$line =~ /^[a-z]$/ or
3441
$errorMsg = "please enter k[a-z]", return 0;
3442
$startRange == $endRange or
3443
$errorMsg = "cannot label an entire range", return 0;
3444
substr($labels, (ord($line) - ord('a'))*$lnwidth, $lnwidth) =
3445
sprintf $lnformat, $endRange;
3446
return 1;
3447
}
3448
3449
$nsuf = $line if $line =~ /^\d+$/ and ! $postspace;
3450
$cx = $nsuf - 1;
3451
3452
if($cmd eq 'f') {
3453
if($nsuf >= 0) {
3454
(cxCompare($cx) and cxActive($cx)) or return 0;
3455
$j = $fname[$cx];
3456
print(length($j) ? $j : "no file");
3457
print " [binary]" if $fmode[$cx]&$binmode;
3458
print "\n";
3459
return 1;
3460
}
3461
if(length $line) {
3462
$errorMsg = "cannot change the name of a directory", return 0 if $fmode&$dirmode;
3463
$fname = $line;
3464
} else {
3465
print(length($fname) ? $fname : "no file");
3466
print " [binary]" if $fmode&$binmode;
3467
print "\n";
3468
}
3469
return 1;
3470
} # f
3471
3472
if($cmd eq 'q') {
3473
$nsuf < 0 or (cxCompare($cx) and cxActive($cx)) or return 0;
3474
if($nsuf < 0) {
3475
$cx = $context;
3476
$errorMsg = "unexpected text after the $icmd command", return 0 if length $line;
3477
}
3478
cxReset($cx, 1) or return 0;
3479
return 1 if $cx != $context;
3480
# look around for another active session
3481
while(1) {
3482
$cx = 0 if ++$cx > $#factive;
3483
exit 0 if $cx == $context;
3484
next if ! defined $factive[$cx];
3485
cxSwitch($cx, 1);
3486
return 1;
3487
}
3488
} # q
3489
3490
if($cmd eq 'w') {
3491
if($nsuf >= 0) {
3492
$writeMode eq ">" or
3493
$errorMsg = "sorry, append to buffer not yet implemented", return 0;
3494
return writeContext($cx)
3495
}
3496
$line = $fname if ! length $line;
3497
if($fmode&$dirmode and $line eq $fname) {
3498
$errorMsg = "cannot write to the directory; files are modified as you go";
3499
return 0;
3500
}
3501
return writeFile($writeMode, $line) if length $line;
3502
$errorMsg = "no file specified";
3503
return 0;
3504
} # w
3505
3506
# goto a file in a directory
3507
if($fmode&$dirmode and $cmd eq 'g' and ! length $line) {
3508
$cmd = 'e';
3509
$line = $dirname . '/' . fetchLine($endRange, 0);
3510
}
3511
3512
if($cmd eq 'e') {
3513
return (cxCompare($cx) and cxSwitch($cx, 1)) if $nsuf >= 0;
3514
if(!length $line) {
3515
$j = $context + 1;
3516
print "session $j\n";
3517
return 1;
3518
}
3519
} # e
3520
3521
if($cmd eq 'g' and $line =~ /^\d*$/) {
3522
($j, $line) = hyperlink($line);
3523
return 0 unless $j;
3524
# Go on to browse the file.
3525
} # goto link
3526
3527
if($cmd eq '^') {
3528
! length $line or $nsuf >= 0 or
3529
$errorMsg = "unexpected text after the ^ command", return 0;
3530
$nsuf = 1 if $nsuf < 0;
3531
while($nsuf) {
3532
$errorMsg = "no previous text", return 0 if ! defined $backup;
3533
cxReset($context, 2) or return 0;
3534
$h = $backup;
3535
$backup = $$h{backup};
3536
cxUnpack($h);
3537
--$nsuf;
3538
}
3539
# Should this print be inside or outside the loop?
3540
if($dot) { dispLine($dot); } else { print "empty file\n"; }
3541
return 1;
3542
} # ^
3543
3544
if($cmd eq 'A') {
3545
return showLinks();
3546
} # A
3547
3548
if($icmd eq 's' or $icmd eq 'S') {
3549
# A few shorthand notations.
3550
if($line =~ /^([,.;:!?)"-])(\d?)$/) {
3551
my $suffix = $2;
3552
$line = "$1 +";
3553
# We have to escape the question mark and period
3554
$line =~ s/^([?.])/\\$1/;
3555
$line = "/$line/$1\\n";
3556
$line .= "/$suffix" if length $suffix;
3557
}
3558
} # original command was s
3559
3560
readyUndo if ! $inglob;
3561
3562
if($cmd eq 'g' or $cmd eq 'v') {
3563
return doGlobal($line);
3564
} # global
3565
3566
if($cmd eq 'I') {
3567
$fmode&$browsemode or $errorMsg = $nobrowse, $inglob = 0, return 0;
3568
3569
if($line =~ /^\d*\?/) { # status
3570
$inglob and $errorMsg = $inoglobal, $inglob = 0, return 0;
3571
$startRange == $endRange or $errorMsg = $inorange, return 0;
3572
infIndex($endRange, $line) > 0 or return 0;
3573
infStatus($line);
3574
return 1;
3575
} # get info on input field
3576
3577
if($line =~ /^\d*([=<])/) {
3578
my $asg = $1;
3579
$subprint = 1;
3580
my $yesdot = 0;
3581
my $t = $line;
3582
$t =~ s/^\d*[=<]//;
3583
if($asg eq '<') {
3584
if($t =~ /^\d+$/) {
3585
my $cx = $t-1;
3586
cxCompare($cx) and cxActive($cx) or $inglob = 0, return 0;
3587
my $dolcx = $dol[$cx];
3588
$dolcx == 1 or $errorMsg = "session $t should contain exactly one line", $inglob = 0, return 0;
3589
$t = fetchLineContext(1, 1, $cx);
3590
} else {
3591
$errorMsg = "";
3592
$t = envFile $t;
3593
length($errorMsg) and $inglob = 0, return 0;
3594
open FH, $t or $errorMsg = "cannot open $t, $!", $inglob = 0, return 0;
3595
$t = <FH>;
3596
defined $t or $errorMsg = "empty file", $inglob = 0, return 0;
3597
if(defined <FH>) {
3598
close FH;
3599
$errorMsg = "file contains more than one line";
3600
$inglob = 0;
3601
return 0;
3602
}
3603
close FH;
3604
$t =~ s/[\r\n]+$//;
3605
}
3606
} # I<file
3607
foreach $i ($startRange..$endRange) {
3608
my $rc = infIndex($i, $line);
3609
next unless $rc;
3610
$dot = $i;
3611
$rc > 0 and infReplace($t) or $inglob = 0, return 0;
3612
$yesdot = $dot;
3613
} # loop over lines
3614
if($yesdot) {
3615
dispLine($yesdot) if ! $inglob;
3616
return 1;
3617
}
3618
$errorMsg = "no input fields present" if ! $inglob;
3619
return 0;
3620
} # i=
3621
3622
if($line =~ /^\d*\*$/) {
3623
$inglob and $errorMsg = $inoglobal, $inglob = 0, return 0;
3624
$startRange == $endRange or $errorMsg = $inorange, return 0;
3625
infIndex($endRange, $line) > 0 or return 0;
3626
($j, $line, $post) = infPush();
3627
# return code of -1 means there's more to do.
3628
return $j unless $j < 0;
3629
} elsif( $line !~ m&^\d*[$valid_delim]&o) {
3630
$errorMsg = "unknown input field directive, please use I? or I= or I/text/replacement/";
3631
return 0;
3632
}
3633
} # input field
3634
3635
# Pull section indicator off of a url.
3636
$section = $1 if $cmd eq 'b' and $line =~ s/(#.*)//;
3637
3638
if(($cmd eq 'b' or $cmd eq 'e') and length $line) {
3639
$h = undef;
3640
$h = cxPack() if $dol and ! $nostack;
3641
cxReset($context, 0) or return 0;
3642
$startRange = $endRange = 0;
3643
$changeFname = "";
3644
if($line =~ /^\x80mail\x80(.*)$/) { # special code for sendmail link
3645
$href = $1;
3646
my $subj = urlSubject(\$href);
3647
$subj = "Comments" unless length $subj;
3648
if(lineLimit 2) {
3649
$i = 0;
3650
} else {
3651
$i = 1;
3652
push @text, "To: $href";
3653
$map .= sprintf($lnformat, $#text);
3654
push @text, "Subject: $subj";
3655
$map .= sprintf($lnformat, $#text);
3656
$dot = $dol = 2;
3657
print "SendMail link. Compose your mail, type sm to send, then ^ to get back.\n";
3658
apparentSize();
3659
}
3660
} else {
3661
$fname = $line;
3662
$i = readFile($fname, $post);
3663
$fmode &= ~($changemode|$firstopmode);
3664
}
3665
$filesize = -1, cxUnpack($h), return 0 if !$i and ! $dol and is_url($fname);
3666
if(defined $h) {
3667
$$h{backup} = $backup if defined $backup;
3668
$backup = $h;
3669
}
3670
return 0 if ! $i;
3671
$fname = $changeFname if length $changeFname;
3672
$cmd = 'e' if $fmode&$binmode or ! $dol;
3673
return 1 if $cmd eq 'e';
3674
}
3675
3676
if($cmd eq 'b') {
3677
if(! ($fmode&$browsemode)) {
3678
readyUndo();
3679
print("$filesize\n"), $filesize = -1 if $filesize >= 0;
3680
render() or return 0;
3681
if(defined $postBrowse) {
3682
$$btags[0]{pb} = $postBrowse;
3683
evaluateSequence($postBrowse, 0);
3684
if($$btags[0]{dol2} > $dol) {
3685
$fmode &= ~($changemode|$firstopmode);
3686
apparentSize();
3687
}
3688
}
3689
} else {
3690
$errorMsg = "already browsing", return 0 if ! length $section;
3691
}
3692
return 1 if ! length $section;
3693
$section =~ s/^#//;
3694
$j = findSection($section);
3695
$errorMsg = "cannot locate section #$section", return 0 unless $j;
3696
$dot = $j;
3697
dispLine($dot);
3698
return 1;
3699
} # b
3700
3701
if($cmd eq 'm' or $cmd eq 't') {
3702
return moveCopy();
3703
}
3704
3705
if($cmd eq 'i') {
3706
$cmd = 'a';
3707
--$startRange, --$endRange;
3708
}
3709
3710
if($cmd eq 'c') {
3711
delText($startRange, $endRange) or return 0;
3712
$endRange = --$startRange;
3713
$cmd = 'a';
3714
}
3715
3716
if($cmd eq 'a') {
3717
return readLines();
3718
}
3719
3720
if($cmd eq 'd') {
3721
$i = ($endRange == $dol);
3722
if($fmode & $dirmode) {
3723
$j = delFiles();
3724
} else {
3725
$j = delText($startRange, $endRange);
3726
}
3727
$inglob = 0 if ! $j;
3728
if($j and $delprint and ! $inglob) {
3729
$i ? print "end of file\n" : dispLine($dot);
3730
}
3731
return $j;
3732
} # d
3733
3734
if($cmd eq 'j' or $cmd eq 'J') {
3735
return joinText();
3736
} # j
3737
3738
if($cmd eq 'r') {
3739
return readContext($cx) if $nsuf >= 0;
3740
return readFile($line, "") if length $line;
3741
$errorMsg = "no file specified";
3742
return 0;
3743
} # r
3744
3745
if($cmd eq 's' or $cmd eq 'I') {
3746
$j = substituteText($line);
3747
$inglob = $j = 0 if $j < 0;
3748
return $j;
3749
} # substitute
3750
3751
$errorMsg = "command $icmd not yet implemented";
3752
$inglob = 0;
3753
return 0;
3754
} # evaluate
3755
3756
sub evaluateSequence($$)
3757
{
3758
my $commands = shift;
3759
my $check = shift;
3760
foreach my $go (@$commands) {
3761
$inglob = 0;
3762
$intFlag = 0;
3763
$filesize = -1;
3764
my $rc = evaluate($go);
3765
print "$filesize\n" if $filesize >= 0;
3766
$rc or ! $check or
3767
return 0;
3768
}
3769
return 1;
3770
} # evaluateSequence
3771
3772
# Hash to map html tags onto their English descriptions.
3773
# For instance, P maps to "paragraph".
3774
# Most of the tags, such as FONT, map to nothing,
3775
# whence they are thrown away.
3776
# The first two characters are not part of the description.
3777
# It forms a number that describes the nestability of the tag.
3778
# Bit 1 means the tag should be nested, like parentheses.
3779
# In fact all the bit1 tags should nest amongst eachother, unlike
3780
# <UL> <TABLE> </UL> </TABLE> (nesting error).
3781
# Bit 2 means a tag may appear inside itself, like nested lists.
3782
# Bit 4 means the tag implies a paragraph break.
3783
# Bit 8 means we retain attributes on the positive tag.
3784
# bit 16 means to close an open anchor *before* applying this tag
3785
%tagdesc = (
3786
sub => "11a subscript",
3787
font => " 3a font",
3788
center => " 3centered text",
3789
sup => "11a superscript",
3790
title => "17the title",
3791
head => "17the html header information",
3792
body => "27the html body",
3793
bgsound => "24background music",
3794
meta => " 8a meta tag",
3795
base => " 8base reference for relative URLs",
3796
img => " 8an image",
3797
br => " 0a line break",
3798
p => "20a paragraph",
3799
blockquote => "20a quoted paragraph",
3800
div => "20a divided section",
3801
h => "21a header",
3802
dt => "20a term",
3803
dd => "20a definition",
3804
hr => "16a horizontal line",
3805
ul => "23a bullet list",
3806
ol => "23a numbered list",
3807
dl => "23a definition list",
3808
li => "16a list item",
3809
form => "25a form",
3810
input => "24an input item",
3811
a => "25an anchor",
3812
frame => "28a frame",
3813
map => "28An image map",
3814
area => "24an image map area",
3815
# I've seen tables nested inside tables -- I don't know why!
3816
table => "31a table",
3817
tr => "19a table row",
3818
td => "19a table entry",
3819
th => "19a table heading",
3820
pre => " 5a preformatted section",
3821
xmp => " 5a preformatted section",
3822
address => " 5a preformatted section",
3823
script => " 1a script",
3824
style => " 1a style block",
3825
noframes => " 1noframe section",
3826
select => "25an option list",
3827
textarea => "25an input text area",
3828
option => "24a select option",
3829
# The following tags convey formatting information that is eventually
3830
# discarded, but I'll track them for a while,
3831
# just to verify nestability.
3832
em => " 1a block of emphasized text",
3833
strong => " 1a block of emphasized text",
3834
b => " 1a block of bold text",
3835
i => " 1a block of italicized text",
3836
code => " 1a block of sample code",
3837
samp => " 1a block of sample code",
3838
);
3839
3840
# We encode tags in a @tag attribute=value attribute=value ...@ format,
3841
# though of course we don't use the @ sign.
3842
# We use \x80, which should not appear in international text.
3843
# I simply hard code it - it makes things simpler.
3844
3845
# Support routine, to encode a tag.
3846
# Run from within a global substitute.
3847
# Pas the name of the tag, slash, and tag arguments
3848
sub processTag($$$)
3849
{
3850
my ($tag, $slash, $attributes) = @_;
3851
my $nlcount = $attributes =~ y/\n/\n/; # newline count
3852
my $doat = 0; # do attributes
3853
$tag = lc $tag;
3854
my $desc = $tagdesc{$tag};
3855
if(defined $desc) {
3856
$doat = (substr($desc, 0, 2) & 8);
3857
} else {
3858
$tag = "z";
3859
}
3860
# Do we need to gather up the attributes?
3861
if(!$doat or $slash eq "/") {
3862
# Guess not, just return the tag.
3863
return "" if $tag eq "z" and ! $nlcount;
3864
return "\x80$tag$slash$nlcount\x80";
3865
}
3866
# Process each whitespace separated chunk, taking quotes into account.
3867
# note that name="foo"size="1" is suppose to be two separate tags;
3868
# God help us!
3869
# Borrow a global variable, even though this may not be an input tag.
3870
$itag = {tag => $tag};
3871
push @$btags, $itag;
3872
$attributes =~ s/( # replace the entire matched text
3873
\w+ # attribute name
3874
(?>\s*=\s* # as in name=value
3875
(?> # a sequence of choices
3876
[^\s"']+ # regular printable characters
3877
|
3878
"[^"]*" # double quoted string
3879
|
3880
'[^']*' # single quoted string
3881
) # one of three formats
3882
)? # =value
3883
)/processAttr($1)/xsge;
3884
# Capture description and keywords.
3885
if($tag eq "meta") {
3886
my $val = $$itag{name};
3887
if(defined $val) {
3888
$val = lc $val;
3889
if($val eq "description" or $val eq "keywords") {
3890
my $content = $$itag{content};
3891
if(defined $content) {
3892
stripWhite \$content;
3893
$$btags[0]{$val} = $content if length $content;
3894
} # content
3895
} # description or keywords
3896
} # name=
3897
pop @$btags;
3898
return "" unless $nlcount;
3899
return "\x80z$nlcount\x80";
3900
} # meta tag
3901
my $tagnum = $#$btags;
3902
return "\x80$tag$nlcount,$tagnum\x80";
3903
} # processTag
3904
3905
# Support routine, to crack attribute=value.
3906
sub processAttr($)
3907
{
3908
my $line = shift;
3909
# Get rid of spaces around first equals.
3910
$line =~ s/^([^=\s]*)\s*=\s*/$1=/;
3911
# Get rid of the quotes.
3912
$line =~ s/("[^"]*"|'[^']*')/substr($1,1,-1)/sge;
3913
my $attr = lc $line;
3914
$attr =~ s/\s*=.*//s;
3915
return "" unless $attr =~ /^\w+$/;
3916
$line =~ s/^[^=]*=//s
3917
or $line = "";
3918
$line =~ s/&([a-zA-Z]+|#\d+);/metaChar($1)/ge;
3919
$$itag{$attr} = $line;
3920
return "";
3921
} # processAttr
3922
3923
# Support routine, to encode a bang tag.
3924
# Run from within a global substitute.
3925
sub processBangtag($)
3926
{
3927
my $item = shift;
3928
if($item eq "'" or $item eq '"') {
3929
return (length $bangtag ? " " : $item);
3930
}
3931
if(substr($item, 0, 1) eq '<') {
3932
return "" if length $bangtag;
3933
return $item if $item eq "<";
3934
$bangtag = substr $item, 1;
3935
return "<z ";
3936
}
3937
return $item unless length $bangtag;
3938
# dashes at the front require dashes at the end.
3939
# But (apparently) they don't have to be the same number of dashes.
3940
# I really don't understand this syntax at all!
3941
# It is suppose to follow the rules in
3942
# http://www.htmlhelp.com/reference/wilbur/misc/comment.html
3943
# but real web pages hardly ever follow these rules!
3944
substr($item, -1) = ""; # don't need that last >
3945
my $l = length($bangtag) - 1;
3946
$l &= ~1; # back down to an even number
3947
return " " if $l and ! length $item; # lone > inside a comment
3948
$bangtag = "";
3949
return ">";
3950
} # processBangtag
3951
3952
# Turn <>'" in javascript into spaces, as we did above.
3953
sub processScript($)
3954
{
3955
my $item = shift;
3956
if(length($item) < 5) {
3957
return ($inscript ? " " : $item);
3958
}
3959
# now $item is <script or </script
3960
# Try to guard against Java code that looks like
3961
# document_write("<script bla bla bla>\n";
3962
# There's a lot of this going around.
3963
$prequote = 0;
3964
$prequote = 1 if $item =~ s/^\( *['"]//;
3965
return ' ' if $inscript and $prequote;
3966
if(substr($item, 1, 1) eq '/') {
3967
--$inscript if $inscript;
3968
} else {
3969
++$inscript;
3970
}
3971
return $item;
3972
} # processScript
3973
3974
sub backOverSpaces($)
3975
{
3976
my $trunc = shift;
3977
my $j = length($refbuf) - 1;
3978
--$j while $j >= 0 and substr($refbuf, $j, 1) =~ /[ \t]/;
3979
++$j;
3980
substr($refbuf, $j) = "" if $trunc;
3981
return $j;
3982
} # backOverSpaces
3983
3984
# Recompute space value, after the buffer has been cropped.
3985
# 0 = word, 1 = spaces, 2 = newline, 3 = paragraph.
3986
sub computeSpace()
3987
{
3988
return 3 if ! length $refbuf;
3989
my $last = substr $refbuf, -1;
3990
return 0 if $last !~ /\s/;
3991
return 1 if $last ne "\n";
3992
return 2 if substr($refbuf, -2) ne "\n\n";
3993
return 3;
3994
} # computeSpace
3995
3996
# Here are the common keywords for mail header lines.
3997
# These are in alphabetical order, so you can stick more in as you find them.
3998
# The more words we have, the more accurate the test.
3999
# Value = 1 means it might be just a "NextPart" mime header,
4000
# rather than a full-blown email header.
4001
# Value = 2 means it could be part of an English form.
4002
# Value = 4 means it's almost certainly a line in a mail header.
4003
%mhWords = (
4004
"action" => 2,
4005
"arrival-date" => 4,
4006
"content-transfer-encoding" => 1,
4007
"content-type" => 1,
4008
"date" => 2,
4009
"delivered-to" => 4,
4010
"errors-to" => 4,
4011
"final-recipient" => 4,
4012
"from" => 2,
4013
"importance" => 4,
4014
"last-attempt-date" => 4,
4015
"list-id" => 4,
4016
"mailing-list" => 4,
4017
"message-id" => 4,
4018
"mime-version" => 4,
4019
"precedence" => 4,
4020
"received" => 4,
4021
"remote-mta" => 4,
4022
"reply-to" => 4,
4023
"reporting-mta" => 4,
4024
"return-path" => 4,
4025
"sender" => 4,
4026
"status" => 2,
4027
"subject" => 4,
4028
"to" => 2,
4029
"x-beenthere" => 4,
4030
"x-loop" => 4,
4031
"x-mailer" => 4,
4032
"x-mailman-version" => 4,
4033
"x-mimeole" => 4,
4034
"x-ms-tnef-correlator" => 4,
4035
"x-msmail-priority" => 4,
4036
"x-priority" => 4,
4037
"x-uidl" => 4,
4038
);
4039
4040
# Get a filename from the user.
4041
sub getFileName($$)
4042
{
4043
my $startName = shift;
4044
my $isnew = shift;
4045
input: {
4046
print "Filename: ";
4047
print "[$startName] " if defined $startName;
4048
my $line = <STDIN>;
4049
exit 0 unless defined $line;
4050
stripWhite \$line;
4051
if($line eq "") {
4052
redo input if ! defined $startName;
4053
$line = $startName;
4054
} else {
4055
$startName = undef;
4056
$line = envLine $line;
4057
print("$errorMsg\n"), redo input if length $errorMsg;
4058
} # blank line
4059
if($isnew and -e $line) {
4060
print "Sorry, file $line already exists.\n";
4061
$startName = undef;
4062
redo input;
4063
}
4064
return $line;
4065
}
4066
} # getFileName
4067
4068
# Get a character from the tty, raw mode.
4069
# For some reason hitting ^c in this routine doesn't leave the tty
4070
# screwed up. I don't know why not.
4071
sub userChar
4072
{
4073
my $choices = shift;
4074
input: {
4075
# Too bad there isn't a perl in-built for this.
4076
# I don't know how to do this in Windows. Help anybody?
4077
system "stty", "-icanon", "-echo";
4078
my $c = getc;
4079
system "stty", "icanon", "echo";
4080
if(defined $choices and index($choices, $c) < 0) {
4081
STDOUT->autoflush(1);
4082
print "\a\b";
4083
STDOUT->autoflush(0);
4084
redo input;
4085
}
4086
return $c;
4087
}
4088
} # userChar
4089
4090
# Encode html page or mail message.
4091
# No args, the html is stored in @text, as indicated by $map.
4092
sub render()
4093
{
4094
$dol or $errorMsg = "empty file", return 0;
4095
$errorMsg = "binary file", return 0 if $fmode&$binmode;
4096
$errorMsg = "cannot render a directory", return 0 if $fmode&$dirmode;
4097
4098
my ($i, $j, $k, $rc);
4099
my $type = "";
4100
$btags[$context] = $btags = [];
4101
$$btags[0] = {tag => "special", fw => {} };
4102
4103
# If it starts with html, head, or comment, we'll call it html.
4104
my $tbuf = fetchLine 1, 0;
4105
if($tbuf =~ /^\s*<(?:!-|html|head|meta)/i) {
4106
$type = "html";
4107
}
4108
4109
if(! length $type) {
4110
# Check for mail header.
4111
# There might be html tags inside the mail message, so we need to
4112
# look for mail headers first.
4113
# This is a very simple test - hopefully not too simple.
4114
# The first 20 non-indented lines have to look like mail header lines,
4115
# with at least half the keywords recognized.
4116
$j = $k = 0;
4117
for $i (1..$dol) {
4118
my $line = fetchLine $i, 0;
4119
last unless length $line;
4120
next if $line =~ /^[ \t]/; # indented
4121
++$j;
4122
next unless $line =~ /^([\w-]+):/;
4123
my $word = lc $1;
4124
my $v = $mhWords{$word};
4125
++$k if $v;
4126
if($k >= 4 and $k*2 >= $j) {
4127
$type = "mail";
4128
last;
4129
}
4130
last if $j > 20;
4131
}
4132
}
4133
4134
if($type ne "mail") {
4135
# Put the lines together into one long string.
4136
# This is necessary to check for, and render, html.
4137
$tbuf .= "\n";
4138
$tbuf .= fetchLine($_, 0) . "\n" foreach (2..$dol);
4139
}
4140
4141
if(! length $type) {
4142
# Count the simple html tags, we need at least two per kilabyte.
4143
$i = length $tbuf;
4144
$j = $tbuf =~ s/(<\/?[a-zA-Z]{1,7}\d?[>\s])/$1/g;
4145
$j = 0 if $j eq "";
4146
$type = "html" if $j * 500 >= $i;
4147
}
4148
4149
if(! length $type) {
4150
$errorMsg = "this doesn't look like browsable text";
4151
return 0;
4152
}
4153
4154
$badHtml = 0;
4155
$badHtml = 1 if is_url($fname);
4156
$rc = renderMail(\$tbuf) if $type eq "mail";
4157
$rc = renderHtml(\$tbuf) if $type eq "html";
4158
return 0 unless $rc;
4159
4160
pushRenderedText(\$tbuf) or return 0;
4161
if($type eq "mail") {
4162
$fmode &= ~$browsemode; # so I can run the next command
4163
evaluate(",bl");
4164
$errorMsg = "";
4165
$dot = $dol;
4166
$fmode &= ~$changemode;
4167
$fmode |= $browsemode;
4168
}
4169
apparentSize();
4170
$tbuf = undef;
4171
4172
if($type eq "mail" and $nat) {
4173
print "$nat attachments.\n";
4174
$j = 0;
4175
foreach $curPart (@mimeParts) {
4176
next unless $$curPart{isattach};
4177
++$j;
4178
print "Attachment $j\n";
4179
my $filename = getFileName($$curPart{filename}, 1);
4180
next if $filename eq "x";
4181
if($filename eq "e") {
4182
print "session " . (cxCreate(\$$curPart{data}, $$curPart{filename})+1) . "\n";
4183
next;
4184
}
4185
if(open FH, ">$filename") {
4186
binmode FH, ':raw' if $doslike;
4187
print FH $$curPart{data}
4188
or dieq "Cannot write to attachment file $filename, $!.";
4189
close FH;
4190
} else {
4191
print "Cannot create attachment file $filename.\n";
4192
}
4193
} # loop over attachments
4194
print "attachments complete.\n";
4195
} # attachments present
4196
4197
return 1;
4198
} # render
4199
4200
# Pass the reformatted text, without its last newline.
4201
sub pushRenderedText($)
4202
{
4203
my $tbuf = shift;
4204
4205
# Replace common nonascii symbols
4206
# I don't know what this pair of bytes is for!
4207
$$tbuf =~ s/\xe2\x81//g;
4208
4209
# Transliterate alternate forms of quote, apostrophe, etc.
4210
# We replace escape too, cuz it shouldn't be there anyways, and it messes up
4211
# some terminals, and some adapters.
4212
# Warning!! Don't change anything in the range \x80-\x8f.
4213
# These codes are for internal use, and mus carry through.
4214
$$tbuf =~ y/\x1b\x95\x99\x9c\x9d\x92\x93\x94\xa0\xad\x96\x97/_*'`''`' \55\55\55/;
4215
4216
# Sometimes the bullet list indicator is falsely separated from the subsequent text.
4217
$$tbuf =~ s/\n\n\*\n\n/\n\n* /g;
4218
4219
# Turn nonascii math symbols into our encoded versions of math symbols,
4220
# to be handled like Greek letters etc, in a consistent manner,
4221
# by the next block of code.
4222
$$tbuf =~ s/\xb0/\x82176#/; # degrees
4223
$$tbuf =~ s/\xbc/\x82188#/; # 1 fourth
4224
$$tbuf =~ s/\xbd/\x82189#/; # 1 half
4225
$$tbuf =~ s/\xbe/\x82190#/; # 3 fourths
4226
$$tbuf =~ s/\xd7/\x82215#/; # times
4227
$$tbuf =~ s/\xf7/\x82247#/; # divided by
4228
4229
if($$tbuf =~ /\x82\d+#/) { # we have codes to expand.
4230
# These symbols are going to become words -
4231
# put spaces on either side, if the neighbors are also words.
4232
$$tbuf =~ s/#\x82/# \x82/g;
4233
$$tbuf =~ s/([a-zA-Z\d])(\x82\d+#)/$1 $2/g;
4234
$$tbuf =~ s/(\x82\d+#)([a-zA-Z\d])/$1 $2/g;
4235
$$tbuf =~ s/\x82(\d+)#/$symbolWord{$1}/ge;
4236
}
4237
4238
# Now push into lines, for the editor.
4239
my $j = $#text;
4240
if(length $$tbuf) {
4241
push @text, split "\n", $$tbuf, -1;
4242
} else {
4243
push @text, "";
4244
}
4245
$#text = $j, return 0 if lineLimit 0;
4246
4247
$$btags[0]{map1} = $map;
4248
$$btags[0]{dot} = $dot;
4249
$$btags[0]{dol1} = $dol;
4250
$dot = $dol = $#text - $j;
4251
$$btags[0]{dol2} = $dol;
4252
$map = $lnspace;
4253
$map .= sprintf($lnformat, $j) while ++$j <= $#text;
4254
$$btags[0]{map2} = $map;
4255
$fmode &= ~$firstopmode;
4256
$$btags[0]{fname} = $fname;
4257
$$btags[0]{fmode} = $fmode;
4258
$$btags[0]{labels} = $labels;
4259
$fmode &= $changemode; # only the change bit retains its significance
4260
$fmode |= $browsemode;
4261
$labels = $lnspace x 26;
4262
$fname .= ".browse" if length $fname;
4263
return 1;
4264
} # pushRenderedText
4265
4266
# Pass in the text to be rendered, by reference.
4267
# The text is *replaced* with the rendered text.
4268
sub renderHtml($)
4269
{
4270
my $tbuf = shift;
4271
my ($i, $j, $ofs1, $ofs2, $h); # variables
4272
4273
$baseref = $fname;
4274
4275
# Ok, here's a real kludge.
4276
# The utility that converts pdf to html,
4277
# access.adobe.com/simple_form.html, has a few quirks.
4278
# One of the common problems in the translation is
4279
# the following meaningless string, that appears over and over again.
4280
# I'm removing it here.
4281
$$tbuf =~ s/Had\strouble\sresolving\sdest\snear\sword\s(<[\w_;:\/'"().,-]+>\s)?action\stype\sis\sGoToR?//g;
4282
4283
# I don't expect any overstrikes, but just in case ...
4284
$$tbuf =~ s/[^<>"'&\n]\10//g;
4285
# Get rid of any other backspaces.
4286
$$tbuf =~ y/\10/ /d;
4287
4288
# Make sure there aren't any \x80 characters to begin with.
4289
$$tbuf =~ y/\x80/\x81/;
4290
4291
# As far as I can tell, href=// means href=http://
4292
# Is this documented anywhere??
4293
$$tbuf =~ s,\bhref=(["']?)//\b,HREF=$1http://,ig;
4294
4295
# Find the simple window javascript functions
4296
$refbuf = "";
4297
$lineno = $colno = 1;
4298
$lspace = 3;
4299
javaFunctions($tbuf);
4300
4301
# Before we do the standard tags, get rid of the <!-- .. --> tags.
4302
# I turn them into <z ... > tags,
4303
# which will be disposed of later, along with all the
4304
# other unrecognized tags.
4305
# This is not a perfect implementation.
4306
# It will glom onto the <! inside <A HREF="xyz<!stuff">,
4307
# and it shouldn't; but niehter should you be writing such a perverse string!
4308
$$tbuf =~ s/<!-*>//g;
4309
$bangtag = "";
4310
$$tbuf =~ s/(['"]|<(!-*)?|-*>)/processBangtag($1)/ge;
4311
print "comments stripped\n" if $debug >= 6;
4312
4313
$errorMsg = $intMsg, return 0 if $intFlag;
4314
4315
# A good web page encloses its javascript in comments <!-- ... -->,
4316
# But some don't, and the (sometimes quoted) < > characters
4317
# really mess us up. Let's try to strip the javascript,
4318
# or any other script for that matter.
4319
$inscript = 0;
4320
$$tbuf =~ s/((?>(\( *['"])?<(\/?script[^>]*>)?|[>"']))/processScript($1)/gei;
4321
print "javascript stripped\n" if $debug >= 6;
4322
4323
$errorMsg = $intMsg, return 0 if $intFlag;
4324
4325
# I'm about to crack html tags with one regexp,
4326
# and that would be entirely doable, if people and web tools didn't
4327
# generate crappy html.
4328
# The biggest problem is unbalanced quotes, whence the open quote
4329
# swallows the rest of the document in one tag.
4330
# I'm goint to *try*, emphasis on try, to develop a few heuristics
4331
# that will detect some of the common misquotings.
4332
# This stuff should be written in C, a complex procedural algorithm.
4333
# But I don't have the time or inclination to translate this mess into C,
4334
# and perl is not the write language to write an algorithm like that.
4335
# I've seen examples of all of these syntactical nightmares on the web,
4336
# and others that I can't possibly code around.
4337
# Only one quote in the tag; get rid of it. Tag is on one line.
4338
$$tbuf =~ s/<(\/?[a-zA-Z][^<>'"]*)['"]([^<>'"]*)>/<$1$2>/g;
4339
# Two quotes before the last >, but not ="">, which would be ok.
4340
$$tbuf =~ s/([^= <>])"">/$1">/g;
4341
$$tbuf =~ s/([^= <>])''>/$1'>/g;
4342
# Missing quote before the last > "word>
4343
# It's usually the last > where things screw up.
4344
$$tbuf =~ s/["'](\w+)>/$1>/g;
4345
#   is suppose to have a semi after it - it often doesn't.
4346
$$tbuf =~ s/ $/ /gi;
4347
$$tbuf =~ s/ ([^;])/ $1/gi;
4348
# Well that's all I can manage right now.
4349
4350
# Encode <font face=symbol> number characters.
4351
# This is kludgy as hell, but I want to be able to read my own math pages.
4352
$$tbuf =~ s/<font +face=['"]?symbol['"]?> *([a-zA-Z]|&#\d+;) *<\/font>/metaSymbol($1)/gei;
4353
4354
# Now let's encode the tags.
4355
# Thanks to perl, we can do it in one regexp.
4356
$$tbuf =~ s/< # start the tag
4357
(\/?) # leading slash turns off the tag
4358
([a-zA-Z]+) # name of the tag
4359
( # remember the attributes
4360
(?> # fix each subexpression as you find it
4361
[^>"']+ # unquoted stuff inside the tag
4362
|
4363
"[^"]*" # stuff in double quotes
4364
|
4365
'[^']*' # stuff in single quotes
4366
)* # as many of these chunks as you need
4367
) # return the set in $3
4368
> # close the html tag
4369
/processTag($2, $1, $3)/xsge;
4370
print "tags encoded\n" if $debug >= 6;
4371
4372
$errorMsg = $intMsg, return 0 if $intFlag;
4373
4374
# Now we can crunch the meta chars without fear.
4375
$$tbuf =~ s/&([a-zA-Z]+|#\d+);/metaChar($1)/ge;
4376
print "meta chars translated\n" if $debug >= 6;
4377
4378
$onloadSubmit = 0;
4379
$longcut = $lperiod = $lcomma = $lright = $lany = 0;
4380
4381
my @olcount = (); # Where are we in each nested number list?
4382
my @dlcount = (); # definition lists
4383
my $tagnest = "."; # Stack the nestable html tags, such as <LI> </LI>
4384
my $tagLock = 0; # other tags are locked out, semantically, until this one is done
4385
my $tagStart; # location of the tag currently under lock
4386
# Locking tags are currently: title, select, textarea
4387
my $inhref = 0; # in anchor reference
4388
my $intitle = 0;
4389
my $inselect = 0;
4390
my $inta = 0; # text area
4391
my $optStart; # start location of option
4392
my $opt; # hash of options
4393
my $optCount; # count of options
4394
my $optSel; # options selected
4395
my $optSize; # size of longest option
4396
my $lastopt; # last option, waiting for next <option>
4397
my $premode = 0; # preformatted mode
4398
my $hrefTag;
4399
my $hrefFile = "";
4400
$inscript = 0;
4401
my $intable = 0; # in table
4402
my $intabhead = 0; # in table header
4403
my $intabrow = 0; # in table row
4404
my $inform = 0; # in form
4405
4406
# Global substitute is mighty powerful, but at this point
4407
# we really need to proceed token by token.
4408
# Going by chunks is better than shifting each character.
4409
# Extract a contiguous sequence of non-whitespace characters,
4410
# or whitespace, or a tag.
4411
reformat:
4412
while($$tbuf =~ /(\s+|\x80[\w\/,]+\x80|[^\s\x80]+)/gs) {
4413
$errorMsg = $intMsg, return 0 if $intFlag;
4414
my $chunk = $1;
4415
4416
# Should we ignore line breaks in table headers?
4417
$chunk = ' ' if ($intabhead|$inhref) and $chunk =~ /^\x80br\/?0/;
4418
4419
if($chunk =~ /^\s/) { # whitespace
4420
$j = $chunk =~ y/\n/\n/; # count newlines
4421
$lineno += $j;
4422
next reformat if $inscript;
4423
if(!$premode or $tagLock) {
4424
next reformat if $lspace;
4425
$chunk = " ";
4426
$chunk = "\n" if $j and substr($refbuf, -4) =~ / [a-zA-Z]\.$/;
4427
appendWhiteSpace($chunk, !($inhref + $tagLock));
4428
# Switch { and space, it looks prettier.
4429
# Hopefully this will never happen accept at the beginning of a link.
4430
$inhref and $lspace == 1 and $refbuf =~ s/(\x80[\x85-\x8f]+{) $/ $1/;
4431
next reformat;
4432
} # not preformatted
4433
4434
# Formfeed is a paragraph break.
4435
$j = 2 if $chunk =~ s/\f/\n\n/g;
4436
$colno = 1 if $j;
4437
# Keep the whitespace after nl, it's preformatted.
4438
$chunk =~ s/.*\n//s;
4439
# Note that we make no effort to track colno or lperiod etc in preformat mode.
4440
if($lspace == 3) {
4441
backOverSpaces(1);
4442
$j = 0;
4443
}
4444
if($j == 2) {
4445
backOverSpaces(1);
4446
$chunk = "\n\n".$chunk if $lspace < 2;
4447
$chunk = "\n".$chunk if $lspace == 2;
4448
$lspace = 3;
4449
$j = 0;
4450
}
4451
if(!$j) {
4452
$refbuf .= $chunk;
4453
next reformat;
4454
}
4455
# Now j = 1 and lspace < 3
4456
backOverSpaces(1);
4457
$refbuf .= "\n$chunk";
4458
$lspace = 1 if ! $lspace;
4459
++$lspace;
4460
next reformat;
4461
} # whitespace
4462
4463
if(substr($chunk, 0, 1) ne "\x80") {
4464
next reformat if $inscript;
4465
$chunk =~ y/{}/[]/ if $inhref;
4466
$inhref = 2 if $inhref;
4467
appendPrintable($chunk);
4468
next reformat;
4469
} # token
4470
4471
# It's a tag
4472
my ($tag, $slash, $nlcount, $attrnum) =
4473
$chunk =~ /^.([a-z]+)(\/?)(\d+)(?:,(\d+))?.$/;
4474
# Unless we hear otherwise, the tag is assumed to contribute no visible
4475
# characters to the finished document.
4476
$chunk = "";
4477
4478
my $desc = $tagdesc{$tag};
4479
$desc = " 0an unknown construct" if ! defined $desc;
4480
my $nest = substr $desc, 0, 2;
4481
$chunk = "\n\n" if $nest & 4;
4482
substr($desc, 0, 2) = "";
4483
# Equivalent tags, as far as we're concerned
4484
$tag = "script" if $tag eq "style";
4485
$tag = "script" if $tag eq "noframes";
4486
$tag = "pre" if $tag eq "xmp";
4487
$tag = "pre" if $tag eq "address";
4488
my $tag1 = ".$tag.";
4489
my $tagplus = "$tag$slash";
4490
$lineno += $nlcount, next reformat if $inscript and $tagplus ne "script/";
4491
$attrnum = 0 if ! defined $attrnum;
4492
# A hidden version of the attribute number, to embed in the text.
4493
$attrhidden = hideNumber $attrnum;
4494
$h = undef;
4495
if($attrnum) {
4496
$h = $$btags[$attrnum];
4497
$$h{lineno} = $lineno; # source line number
4498
}
4499
my $openattr = 0;
4500
my $openattrhidden;
4501
my $openTag;
4502
my $closeAnchor = 0;
4503
$closeAnchor = 1 if $inhref and ($tag eq "a" or $tag eq "area" or $tag eq "frame" or $tag eq "input");
4504
$closeAnchor = 1 if $inhref == 2 and $nest&16;
4505
4506
# Make sure we open and close things in order.
4507
if($nest&1) {
4508
if(!$slash) {
4509
errorConvert("$desc begins in the middle of $desc")
4510
if index($tagnest, $tag1) >= 0 and !($nest&2);
4511
$tagnest = ".$tag.$attrnum" . $tagnest;
4512
push @olcount, 0 if $tag eq "ol";
4513
push @dlcount, 0 if $tag eq "dl";
4514
} else {
4515
$j = index $tagnest, $tag1;
4516
if($j < 0) {
4517
errorConvert("an unexpected closure of $desc, which was never opened");
4518
} else {
4519
if($j > 0) {
4520
my $opendesc = substr $tagnest, 1;
4521
$opendesc =~ s/\..*//;
4522
$opendesc = $tagdesc{$opendesc};
4523
substr($opendesc, 0, 2) = "";
4524
errorConvert("$desc is closed inside $opendesc");
4525
} # bad nesting
4526
++$j;
4527
substr($tagnest, $j, length($tag)+1) = "";
4528
$openattr = substr $tagnest, $j;
4529
$openattr =~ s/\..*//;
4530
substr($tagnest, $j, length($openattr)+1) = "";
4531
$openattrhidden = hideNumber $openattr;
4532
if($openattr) { # record the offset of </tag>
4533
$ofs2 = backOverSpaces(0);
4534
$openTag = $$btags[$openattr];
4535
# Tweak offset for the } on the anchor
4536
++$ofs2 if $closeAnchor and $inhref == 2;
4537
$ofs2 = $tagStart if $tagLock;
4538
$$openTag{ofs2} = $ofs2;
4539
}
4540
pop @olcount if $tag eq "ol";
4541
pop @dlcount if $tag eq "dl";
4542
} # was this construct open or not
4543
} # /tag
4544
} # nestable tag
4545
4546
# retain the start and end of any tag worthy of attributes
4547
if($attrnum) {
4548
$ofs1 = backOverSpaces(0);
4549
$ofs1 = $tagStart if $tagLock;
4550
$$h{ofs1} = $ofs1;
4551
}
4552
4553
switch: {
4554
4555
if($closeAnchor) {
4556
if($inhref == 1) { # no text in the hyperlink
4557
if($refbuf =~ s/( *\x80[\x85-\x8f]+{[\s|]*)$//s) {
4558
$j = $1;
4559
$colno -= $j =~ y/ {/ {/;
4560
} else {
4561
warn "couldn't strip off the open anchor at line $lineno <" .
4562
substr($refbuf, -10) . ">.";
4563
}
4564
$$hrefTag{tag} = "z"; # trash the anchor
4565
} else {
4566
$refbuf .= "}";
4567
$refbuf =~ s/([ \n])}$/}$1/;
4568
++$colno;
4569
$j = $$hrefTag{href};
4570
my $onc = $$hrefTag{onclick};
4571
if($j =~ /^javascript/i or $onc) {
4572
# Let the onclick take precedence.
4573
$j = $onc if defined $onc and length $onc;
4574
# See if this is a javascript function we can recognize and circumvent.
4575
$i = javaWindow $j;
4576
if($$hrefTag{form} and $i eq "submit") {
4577
# I'll assume this is a check and submit function.
4578
# If it only validates fields, we're ok.
4579
# If it reformats the data, we're screwed!
4580
$i = $$hrefTag{ofs1};
4581
$inf = substr $refbuf, $i;
4582
$inf =~ s/{/</;
4583
$inf =~ s/ +$//;
4584
$inf =~ s/}$/ js\x80\x8f>/;
4585
$$hrefTag{$ofs2} += 5;
4586
if($$inform{action}) {
4587
my $actscheme = is_url $$inform{action};
4588
$actscheme = is_url $baseref unless $actscheme;
4589
if($actscheme eq "https") {
4590
$inf =~ s/ js/& secure/;
4591
$$hrefTag{$ofs2} += 7;
4592
}
4593
if($$inform{action} =~ /^mailto:/i) {
4594
$inf =~ s/ js/& mailform/;
4595
$$hrefTag{$ofs2} += 9;
4596
}
4597
}
4598
substr($refbuf, $i) = $inf;
4599
# change it to an input field
4600
$$hrefTag{tag} = "input";
4601
$$hrefTag{type} = "submit";
4602
$$hrefTag{value} = "submit";
4603
$$inform{nnh}++; # another non hidden field
4604
$$inform{nif}++;
4605
$$inform{lnh} = $h; # last non hidden field
4606
}
4607
# Is this just opening a new window, then calling the link?
4608
elsif(length $i and $i ne "submit") {
4609
# Ok, I'll assume it's a new window with hyperlink
4610
$$hrefTag{href} = $i;
4611
} else {
4612
print "unknown javascript ref $j\n" if $debug >= 3;
4613
}
4614
}
4615
}
4616
$lspace = computeSpace();
4617
$inhref = 0;
4618
last switch if $tagplus eq "a/";
4619
} # close the open anchor
4620
4621
if($tagplus eq "sup") {
4622
$refbuf .= '^';
4623
last switch;
4624
} # sup
4625
4626
if($tagplus eq "sup/" and defined $openTag) {
4627
$ofs1 = $$openTag{ofs1};
4628
++$ofs1; # skip past ^
4629
$j = substr $refbuf, $ofs1;
4630
stripWhite \$j;
4631
last switch unless length $j;
4632
if($j =~ /^th|st|rd|nd$/i and
4633
substr($refbuf, $ofs1-2) =~ /\d/) {
4634
--$ofs1;
4635
substr($refbuf, $ofs1, 1) = "";
4636
last switch;
4637
}
4638
last switch if $j =~ /^(\d+|\*)$/;
4639
if(not $allsub) {
4640
last switch if $j =~ /^[a-zA-Z](?:\d{1,2})?$/;
4641
}
4642
(substr $refbuf, $ofs1) = "($j)";
4643
last switch;
4644
} # sup/
4645
4646
if($tagplus eq "sub/" and defined $openTag) {
4647
$ofs1 = $$openTag{ofs1};
4648
$j = substr $refbuf, $ofs1;
4649
stripWhite \$j;
4650
last switch unless length $j;
4651
if(not $allsub) {
4652
last switch if $j =~ /^\d{1,2}$/;
4653
}
4654
(substr $refbuf, $ofs1) = "[$j]";
4655
last switch;
4656
} # sub/
4657
4658
if($tagplus eq "title" and ! $tagLock and ! $intitle) {
4659
$tagStart = length $refbuf;
4660
$tagLock = $intitle = 1;
4661
last switch;
4662
} # title
4663
4664
if($tagplus eq "title/" and $intitle) {
4665
$i = substr $refbuf, $tagStart;
4666
substr($refbuf, $tagStart) = "";
4667
$lspace = computeSpace();
4668
$longcut = 0;
4669
$colno = 1;
4670
if(! defined $$btags[0]{title}) {
4671
stripWhite \$i;
4672
$$btags[0]{title} = $i if length $i;
4673
}
4674
$tagLock = 0;
4675
$intitle = 0;
4676
last switch;
4677
} # title/
4678
4679
if($tagplus eq "li") {
4680
$i = index $tagnest, ".ol.";
4681
$j = index $tagnest, ".ul.";
4682
if($i >= 0) {
4683
if($j >= 0 and $j < $i) {
4684
$chunk = "\n* ";
4685
} else {
4686
$j = ++$olcount[$#olcount];
4687
$chunk = "\n$j. ";
4688
}
4689
} elsif($j >= 0) {
4690
$chunk = "\n* ";
4691
} else {
4692
$chunk = "\n";
4693
errorConvert("$desc appears outside of a list context");
4694
}
4695
last switch;
4696
} # li
4697
4698
if($tagplus eq "dt" or $tagplus eq "dd") {
4699
if(($i = $#dlcount) >= 0) {
4700
$j = ($tag eq "dd" ? 1 : 0);
4701
errorConvert("improper term->definition sequence") if $j != $dlcount[$i];
4702
$dlcount[$i] ^= 1;
4703
} else {
4704
errorConvert("$desc is not contained in a definition list");
4705
}
4706
last switch;
4707
} # dt or dd
4708
4709
# The only thing good about an image is its alt description.
4710
if($tagplus eq "img") {
4711
$hrefFile = "" unless $inhref;
4712
$j = deriveAlt($h, $hrefFile);
4713
$j = "?" if $inhref and length($j) == 0;
4714
if(length $j) {
4715
$refbuf .= $j;
4716
$inhref = 2 if $inhref;
4717
$lspace = 0;
4718
}
4719
last switch;
4720
} # image
4721
4722
if($tagplus eq "body") {
4723
my $onl = $$h{onload}; # popup
4724
$onl = $$h{onunload} unless $onl; # popunder
4725
next unless $onl;
4726
if($onl =~ /submit[.\w]* *\(/i) {
4727
$onloadSubmit = 1;
4728
last switch;
4729
}
4730
$j = javaWindow $onl;
4731
if(length $j and $j ne "submit") {
4732
createHyperLink($h, $j, "onload");
4733
$chunk = "";
4734
last switch;
4735
} # open another window
4736
} # body
4737
4738
if($tagplus eq "bgsound") {
4739
my $j = $$h{src};
4740
if(defined $j and length $j) {
4741
# Someday we'll let you play this right from edbrowse, spawning playmidi
4742
# or mpg123 or whatever. For now I'll let you grab the file yourself.
4743
# Maybe that's better anyways.
4744
createHyperLink($h, $j, "Background music");
4745
$chunk = "\n";
4746
}
4747
last switch;
4748
} # background music
4749
4750
if($tag eq "base") {
4751
$href = $$h{href};
4752
$baseref = urlDecode $href if $href;
4753
next reformat;
4754
} # base tag
4755
4756
if($tagplus eq "a") {
4757
if(defined $$h{name}) {
4758
$refbuf .= "\x80$attrhidden*";
4759
} # name=
4760
if(defined($hrefFile = $$h{href})) {
4761
$$h{form} = $inform;
4762
$inhref = 1;
4763
$hrefTag = $h;
4764
$$h{bref} = $baseref;
4765
# We preserve $lspace, despite pushing visible characters.
4766
$refbuf .= "\x80$attrhidden".'{';
4767
++$colno;
4768
} # href=
4769
last switch;
4770
} # a
4771
4772
if($tagplus eq "area") {
4773
my ($alt, $href);
4774
if(defined($href = $$h{href})) {
4775
$j = javaWindow($href);
4776
$href = $j if length $j and $j ne "submit";
4777
$alt = deriveAlt($h, "");
4778
$alt = $foundFunc if length $foundFunc and not defined $$h{alt};
4779
$alt = "area" unless length $alt;
4780
createHyperLink($h, $href, $alt);
4781
} # hyperlink
4782
} # area
4783
4784
if($tagplus eq "frame") {
4785
my $name = $$h{name};
4786
my $src = $$h{src};
4787
if(defined $src) {
4788
$name = "" if ! defined $name;
4789
stripWhite \$name;
4790
stripWhite \$src;
4791
if(length $src) {
4792
$$h{ofs1} = backOverSpaces(1);
4793
$name = "???" if ! length $name;
4794
$name =~ y/{}\n/[] / if $inhref;
4795
$refbuf .= "frame ";
4796
$colno += 6;
4797
createHyperLink($h, $src, $name);
4798
}} # frame becomes hyperlink
4799
last switch;
4800
} # frame
4801
4802
$premode = 1, last switch if $tagplus eq "pre";
4803
$premode = 0, last switch if $tagplus eq "pre/";
4804
$inscript = 1, last switch if $tagplus eq "script";
4805
$inscript = 0, last switch if $tagplus eq "script/";
4806
$intable++, last switch if $tagplus eq "table";
4807
$intable--, last switch if $tagplus eq "table/" and $intable;
4808
if($tag eq "br") {
4809
$chunk = "\n";
4810
$chunk = "\n\n" if $lspace >= 2;
4811
last switch;
4812
}
4813
$chunk = "\n--------------------------------------------------------------------------------\n\n", last switch if $tagplus eq "hr";
4814
4815
if($tag eq "tr") {
4816
errorConvert("$desc not inside a table") if ! $intable;
4817
$slash ? do { --$intabrow if $intabrow } : ++$intabrow;
4818
$chunk = "\n";
4819
$intabhead = 0;
4820
} # tr
4821
4822
if($tag eq "td" or $tag eq "th") {
4823
errorConvert("$desc not inside a table row") if ! $intabrow;
4824
$intabhead = 0;
4825
$intabhead = 1 - length $slash if $tag eq "th";
4826
if($slash) {
4827
substr($refbuf, -1) = "" if $lspace == 1;
4828
$refbuf .= "|";
4829
$lspace = 1;
4830
}
4831
last switch;
4832
} # td or th
4833
4834
if($tagplus eq "form" and ! ($inform + $tagLock)) {
4835
$inform = $h;
4836
$$h{bref} = $baseref;
4837
$j = lc $$h{method};
4838
$j = "get" if ! defined $j or ! length $j; # default
4839
if($j ne "post" and $j ne "get") {
4840
errorConvert("form method $j not supported");
4841
$j = "get";
4842
}
4843
$$h{method} = $j;
4844
$$h{nnh} = 0; # number of non hidden fields
4845
$$h{nif} = 0; # number of input fields
4846
last switch;
4847
} # form
4848
4849
if($tagplus eq "form/" and $inform) {
4850
# Handle the case with only one visible input field.
4851
if($onloadSubmit or
4852
($$inform{action} or $$inform{onchange}) and
4853
$$inform{nnh} <= 1 and $$inform{nif} and (
4854
$$inform{nnh} == 0 or
4855
($h = $$inform{lnh}) and
4856
$$h{type} ne "submit")) {
4857
$refbuf .= " " if $lspace == 0;
4858
$itag = {tag => "input",
4859
type => "submit", form => $inform,
4860
size => 2, value => "Go"};
4861
push @$btags, $itag;
4862
$j = hideNumber $#$btags;
4863
$refbuf .= "\x80$j<Go\x80\x8f>";
4864
$lspace = 0;
4865
$onloadSubmit = 0;
4866
} # submit button created out of thin air
4867
$inform = 0;
4868
last switch;
4869
} # form/
4870
4871
my $noform = "$desc is not inside a form";
4872
if($tagplus eq "select" and ! $tagLock) {
4873
errorConvert($noform) if ! $inform;
4874
$inselect = $h;
4875
$$inform{onchange} = 1 if $inform and $$h{onchange};
4876
$tagLock = 1;
4877
$tagStart = length $refbuf;
4878
$optCount = $optSel = $optSize = 0;
4879
$lastopt = undef;
4880
$$h{opt} = $opt = {};
4881
last switch;
4882
} # select
4883
4884
if(($tagplus eq "select/" or $tagplus eq "option") and $inselect) {
4885
if(defined $lastopt) {
4886
$j = substr $refbuf, $optStart;
4887
stripWhite \$j;
4888
if(length $j) {
4889
$lastopt =~ s/NoOptValue$/$j/;
4890
$$opt{$j} = $lastopt;
4891
if($optCount < 999) {
4892
++$optCount;
4893
} else {
4894
errorConvert("too many options, limit 999");
4895
}
4896
++$optSel if substr($lastopt, 3, 1) eq '+';
4897
$j = length $j;
4898
$optSize = $j if $j > $optSize;
4899
}}
4900
4901
if($tagplus eq "select/") {
4902
$inselect = 0;
4903
$tagLock = 0;
4904
substr($refbuf, $tagStart) = "";
4905
$lspace = computeSpace();
4906
$colno = 1;
4907
$optCount or errorConvert("no options in the select statement");
4908
my $mult = 0; # multiple select
4909
$mult = 1 if defined $$openTag{multiple};
4910
my $mse = 0; # multiple select error
4911
$optSel <= 1 or $mult or
4912
$mse = 1, errorConvert("multiple options preselected");
4913
$$inform{nnh}++; # another non hidden field
4914
$$inform{nif}++;
4915
$$inform{lnh} = $openTag; # last non hidden field
4916
# Display selected item(s)
4917
$refbuf .= "\x80$openattrhidden<";
4918
my $buflen = length $refbuf;
4919
$i = 0;
4920
foreach (%{$opt}) {
4921
$i ^= 1;
4922
$j = $_, next if $i;
4923
if($mult and $j =~ /,/) {
4924
errorConvert("sorry, option string cannot contain a comma");
4925
$$opt{$j} = ""; # can't delete from hash
4926
next;
4927
}
4928
substr($_, 3, 1) = '-' if $mse;
4929
next unless substr($_, 3, 1) eq '+';
4930
$refbuf .= ',' unless substr($refbuf, -1) eq '<';
4931
$refbuf .= $j;
4932
}
4933
# This is really an input tag.
4934
$$openTag{tag} = "input";
4935
$$openTag{type} = "select";
4936
$$openTag{size} = ($mult ? 0 : $optSize);
4937
$$openTag{value} = substr $refbuf, $buflen;
4938
$$openTag{form} = $inform if $inform;
4939
$refbuf .= "\x80\x8f>";
4940
$lspace = 0;
4941
$$openTag{ofs2} = length $refbuf;
4942
last switch;
4943
}} # select/
4944
4945
if($tagplus eq "option") {
4946
if(! $inselect) {
4947
errorConvert("$desc is not inside a select statement")
4948
} else {
4949
$lastopt = $$h{value};
4950
$lastopt = "NoOptValue" unless defined $lastopt;
4951
$lastopt = (defined $$h{selected} ? "+" : "-") . $lastopt;
4952
$lastopt = sprintf("%03d", $optCount) . $lastopt;
4953
$optStart = length $refbuf;
4954
$$h{tag} = "z";
4955
} # in select or not
4956
last switch;
4957
} # option
4958
4959
if($tagplus eq "textarea" and ! $tagLock) {
4960
errorConvert($noform) if ! $inform;
4961
$inta = $h;
4962
$tagLock = 1;
4963
$tagStart = length $refbuf;
4964
last switch;
4965
} # textarea
4966
4967
if($tagplus eq "textarea/" and $inta) {
4968
# Gather up the original, unformatted text.
4969
$i = "";
4970
foreach $j ($$inta{lineno}..$lineno) {
4971
$i .= fetchLine($j, 0);
4972
$i .= "\n";
4973
}
4974
# Strip off textarea tags.
4975
# I'm not using the s suffix, textarea tags should not cover multiple lines.
4976
$i =~ s/^.*<textarea[^<>]*>\n?//i;
4977
$i =~ s/<\/textarea.*\n$//i;
4978
$i .= "\n" if length $i and substr($i, -1) ne "\n";
4979
$inta = 0;
4980
$tagLock = 0;
4981
substr($refbuf, $tagStart) = "";
4982
my $cx = cxCreate(\$i, "");
4983
$colno = 1;
4984
$$openTag{cx} = $cx;
4985
++$cx;
4986
$$inform{nnh}++; # another non hidden field
4987
$$inform{nif}++;
4988
$$inform{lnh} = $openTag; # last non hidden field
4989
$refbuf .= "\x80$openattrhidden<buffer $cx\x80\x8f>";
4990
$lspace = 0;
4991
# This is really an input tag.
4992
$$openTag{tag} = "input";
4993
$$openTag{ofs1} = $tagStart;
4994
$$openTag{ofs2} = length($refbuf);
4995
$$openTag{type} = "area";
4996
$$openTag{form} = $inform if $inform;
4997
$j = $$openTag{rows};
4998
$j = 0 if ! defined $j;
4999
$j = 0 unless $j =~ /^\d+$/;
5000
$$openTag{rows} = $j;
5001
$j = $$openTag{cols};
5002
$j = 0 if ! defined $j;
5003
$j = 0 unless $j =~ /^\d+$/;
5004
$$openTag{cols} = $j;
5005
last switch;
5006
} # textarea/
5007
5008
if($tagplus eq "input") {
5009
errorConvert($noform) if ! $inform;
5010
$i = lc $$h{type};
5011
$i = "text" unless defined $i and length $i;
5012
$i = "text" if $i eq "password";
5013
# I should verify that the input is a number,
5014
# but I'm too busy right now to implement that.
5015
$i = "text" if $i eq "number";
5016
# Be on the lookout for new, advanced types.
5017
index(".text.checkbox.radio.submit.image.button.reset.hidden.", ".$i.") >= 0 or
5018
errorConvert("unknown input type $i");
5019
$j = $$h{value};
5020
$j = "" unless defined $j;
5021
$$h{saveval} = $j;
5022
if($i eq "radio" or $i eq "checkbox") {
5023
$j = (defined $$h{checked} ? '+' : '-');
5024
}
5025
if($i eq "image") {
5026
$i = "submit";
5027
$$h{image} = 1;
5028
length $j or $j = deriveAlt($h, "submit");
5029
} # submit button is represented by an icon
5030
if($i ne "hidden") {
5031
# I don't think there should be newlines in the value field.
5032
$j =~ y/\n/ /;
5033
}
5034
if($i eq "button") {
5035
# Hopefully we can turn this into a hyperlink.
5036
# If not, it's no use to us.
5037
my $onc = $$h{onclick};
5038
my $page = javaWindow $onc;
5039
$j = "button" unless length $j; # alt=button
5040
if(not length $page and
5041
$onc =~ /self\.location *= *['"]([\w._\/:,=@&?+-]+)["'] *(\+?)/i) {
5042
$page = "$1$2";
5043
}
5044
$i = $page, $page = "" if $page eq "submit";
5045
if(length $page) {
5046
createHyperLink($h, $page, $j);
5047
last switch;
5048
}
5049
} # button
5050
$$h{type} = $i;
5051
$$h{value} = $j;
5052
$$inform{nif}++;
5053
if($i ne "hidden") {
5054
$$inform{nnh}++; # another non hidden field
5055
$$inform{lnh} = $h; # last non hidden field
5056
$refbuf .= "\x80$attrhidden<$j";
5057
if($i eq "submit") {
5058
$refbuf .= " js" if $$inform{onsubmit} or $$h{onclick};
5059
if($$inform{action}) {
5060
my $actscheme = is_url $$inform{action};
5061
$actscheme = is_url $baseref unless $actscheme;
5062
$refbuf .= " secure" if $actscheme eq "https";
5063
$refbuf .= " mailform" if $$inform{action} =~ /^mailto:/i;
5064
}
5065
}
5066
$refbuf .= "\x80\x8f>";
5067
$lspace = 0;
5068
$j = $$h{maxlength};
5069
$j = 0 unless defined $j and $j =~ /^\d+$/;
5070
$j = 1 if $i eq "checkbox" or $i eq "radio";
5071
$$h{size} = $j;
5072
}
5073
if($inform and ! $tagLock) {
5074
$$h{form} = $inform;
5075
$$h{ofs2} = length $refbuf;
5076
}
5077
last switch;
5078
} # input
5079
5080
} # switch on $tag
5081
5082
$lineno += $nlcount;
5083
next reformat unless length $chunk;
5084
5085
# Apparently the tag has forced a line break or paragraph break.
5086
# I've decided to honor this, even in preformat mode,
5087
# because that's what lynx does.
5088
$colno = 1;
5089
$longcut = $lperiod = $lcomma = $lright = $lany = 0;
5090
backOverSpaces(1);
5091
5092
# Get rid of a previous line of pipes.
5093
# This is usually a table or table row of images -- of no use to me.
5094
if($intable and $lspace < 2) {
5095
$j = length($refbuf) - 1;
5096
while($j >= 0 and substr($refbuf, $j, 1) =~ /[|\s]/) {
5097
last if $j > 0 and substr($refbuf, $j-1, 2) eq "\n\n";
5098
--$j;
5099
}
5100
++$j;
5101
if($j < length $refbuf) {
5102
substr($refbuf, $j) = "";
5103
$lspace = computeSpace();
5104
$colno = 1;
5105
}
5106
} # end of line tag inside a table
5107
5108
if($chunk eq "\n\n") {
5109
next reformat if $lspace == 3;
5110
$chunk = "\n" if $lspace == 2;
5111
$lspace = 3;
5112
$refbuf .= $chunk;
5113
next reformat;
5114
} # tag paragraph
5115
5116
# It's a line break.
5117
substr($chunk, 0, 1) = "" if $lspace > 1;
5118
$lspace = 2 if $lspace < 2;
5119
next reformat unless length $chunk;
5120
$refbuf .= $chunk;
5121
$chunk =~ s/^\n//;
5122
next reformat unless length $chunk;
5123
# It's either a list item indicator or a horizontal line
5124
$inhref = 2 if $inhref;
5125
if($chunk =~ /^--/) {
5126
# Again I'm following the lynx convention.
5127
# hr implies a line break before, and aparagraph break after.
5128
$lspace = 3;
5129
} else {
5130
$colno += length $chunk;
5131
$lspace = 1;
5132
}
5133
} # loop over tokens in the buffer
5134
5135
$$tbuf = undef;
5136
print "tags rendered\n" if $debug >= 6;
5137
5138
if(length($tagnest) > 1 and $tagnest ne ".body.0.") {
5139
my $opendesc = substr $tagnest, 1;
5140
$opendesc =~ s/\..*//;
5141
$opendesc = $tagdesc{$opendesc};
5142
substr($opendesc, 0, 2) = "";
5143
--$lineno;
5144
errorConvert("$opendesc is not closed at EOF");
5145
}
5146
5147
$errorMsg = $intMsg, return 0 if $intFlag;
5148
5149
$refbuf =~ s/\s+$//; # don't need trailing blank lines
5150
5151
# In order to fit all the links on one screen, many web sites place
5152
# several links on a line. Sometimes they are separated
5153
# by whitespace, sometimes commas, sometimes hyphens.
5154
# Sometimes they are arranged in a table, and thanks to the
5155
# table rendering software in this program, they will be pipe separated.
5156
# In any case, there is no advantage in having multiple
5157
# links on a line, and it's downright inconvenient when you want to use
5158
# the g or A command. We introduce line breaks between links.
5159
# We use alphanum [punctuation] right brace to locate the end of a link.
5160
# We use { optional '" alphanum for the start of a link.
5161
# These aren't guaranteed to be right, but they probably are most of the time.
5162
# Let's start with link space link or link separater link
5163
$refbuf =~ s/} ?[-,|]? ?(\x80[\x85-\x8f]+{['"]?\w)/}\n$1/g;
5164
# Separating punctuation at the end of the line.
5165
$refbuf =~ s/^({[^{}]+} ?),$/$1/mg;
5166
# Delimiter at the start of line, before the first link.
5167
$refbuf =~ s/\n[-,|] ?(\x80[\x85-\x8f]+{['"]?\w)/\n$1/g;
5168
# word delimiting punctuation space link.
5169
$refbuf =~ s/([a-zA-Z]{2,}[-:|]) (\x80[\x85-\x8f]+{['"]?\w)/$1\n$2/g;
5170
# Link terminating punctuation words
5171
$refbuf =~ s/(\w['"!]?}) ?[-|:] ?(\w\w)/$1\n$2/g;
5172
print "links rearranged\n" if $debug >= 6;
5173
5174
if(! $badHtml) {
5175
# Verify internal links.
5176
intlink:
5177
foreach $h (@$btags) {
5178
$tag = $$h{tag};
5179
next unless $tag eq "a";
5180
$j = $$h{href};
5181
next if ! defined $j;
5182
next unless $j =~ s/^#//;
5183
$refbuf .= ""; # reset match position. Isn't there a better way??
5184
while($refbuf =~ /\x80([\x85-\x8f]+)\*/g) {
5185
$i = revealNumber $1;
5186
next intlink if $$btags[$i]{name} eq $j;
5187
}
5188
$lineno = $$h{lineno};
5189
errorConvert("internal link #$j not found");
5190
last;
5191
} # loop
5192
print "internal links verified\n" if $debug >= 6;
5193
}
5194
5195
# Find the uncalled javascript functions.
5196
my $fw = $$btags[0]{fw}; # pointer to function window hash
5197
my $orphans = 0;
5198
foreach $i (keys %$fw) {
5199
$j = $$fw{$i};
5200
next unless $j =~ s/^\*//;
5201
$orphans = 1, $refbuf .= "\n" unless $orphans;
5202
print "orphan java function $i\n" if $debug >= 3;
5203
$itag = {tag => "a", href => $j, bref => $baseref};
5204
push @$btags, $itag;
5205
my $hn = hideNumber $#$btags;
5206
$refbuf .= "\n jf: $i\x80$hn" . "{$j}";
5207
# I don't think we need to mess with ofs1 and ofs2?
5208
$$itag{ofs2} = length $refbuf;
5209
}
5210
5211
$$tbuf = $refbuf; # replace
5212
return 1;
5213
} # renderHtml
5214
5215
# Report the first html syntax error.
5216
# $lineno tracks the line number, where text is being processed.
5217
sub errorConvert($)
5218
{
5219
$badHtml and return;
5220
my $msg = shift;
5221
# Look at the following print statement, and you'll see the little things
5222
# I try to anticipate when I write software for the blind.
5223
# The first physical line of output is for the sighted user, or the
5224
# new blind user -- but the experienced blind user doesn't need to read it.
5225
# He can read the last line of output, one keystroke in my adaptive software,
5226
# and hear exactly what he want to know.
5227
print "The html text contains syntax errors. The first one is at line\n$lineno: $msg.\n";
5228
# Put the bad line number in label e.
5229
substr($labels, 4*$lnwidth, $lnwidth) =
5230
sprintf $lnformat, $lineno;
5231
$badHtml = 1;
5232
} # errorConvert
5233
5234
# Strip redundent stuff off the start and end of a web page,
5235
# relative to its parent.
5236
sub stripChild()
5237
{
5238
$fmode&$browsemode or $errorMsg = $nobrowse, return 0;
5239
defined $backup or $errorMsg = "no previous web page", return 0;
5240
my $p_fmode = $$backup{fmode};
5241
$p_fmode&$browsemode or $errorMsg = "no previous web page", return 0;
5242
# Parent and child file names should come from the same server.
5243
my $p_fname = $$backup{fname};
5244
my $c_fname = $fname;
5245
is_url($p_fname) and is_url($c_fname) or $errorMsg = "web pages do not come from web servers", return 0;
5246
$p_fname =~ s,^https?://,,i;
5247
$c_fname =~ s,^https?://,,i;
5248
$p_fname =~ s,/.*,,;
5249
$c_fname =~ s,/.*,,;
5250
$p_fname =~ s/\.browse$//;
5251
$c_fname =~ s/\.browse$//;
5252
$p_fname eq $c_fname or $errorMsg = "parent web page comes from a different server", return 0;
5253
$$btags[0]{dol2} == $dol or $errorMsg = "web page already stripped or modified", return 0;
5254
my $p_dol = $$backup{btags}[0]{dol2};
5255
my $c_dol = $dol;
5256
if($p_dol > 10 and $c_dol > 10) {
5257
my $pb = $$backup{btags}[0]{pb};
5258
if(defined $pb) {
5259
evaluateSequence($pb, 0);
5260
if($$btags[0]{dol2} > $dol) {
5261
$fmode &= ~($changemode|$firstopmode);
5262
apparentSize();
5263
$$btags[0]{pb} = $pb;
5264
return 1;
5265
} # successful post browse from the parent page
5266
} # attempting post browse from the parent page
5267
my $p_map = $$backup{btags}[0]{map2};
5268
my $c_map = $map;
5269
my $start = 1;
5270
my $oneout = 0;
5271
while($start <= $p_dol and $start <= $c_dol) {
5272
if(!sameChildLine(\$p_map, $start, \$c_map, $start)) {
5273
last if $oneout;
5274
$oneout = $start;
5275
}
5276
++$start;
5277
}
5278
$start = $oneout if $oneout and $start < $oneout + 5;
5279
my $delcount = --$start;
5280
my $p_end = $p_dol;
5281
my $c_end = $c_dol;
5282
while($p_end > $start and $c_end > $start) {
5283
last unless sameChildLine(\$p_map, $p_end, \$c_map, $c_end);
5284
++$delcount;
5285
--$p_end, --$c_end;
5286
}
5287
if($delcount == $dol) {
5288
my $ln = substr($map, $lnwidth, $lnwidth1);
5289
$text[$ln] = "This web page contains no new information - you've seen it all before.";
5290
print "71\n";
5291
$dol = $dot = 1;
5292
$labels = $lnspace x 26;
5293
$fmode &= ~$firstopmode;
5294
return 1;
5295
}
5296
if($delcount > 5) {
5297
++$c_end;
5298
delText($c_end, $dol) if $c_end <= $dol;
5299
delText(1, $start) if $start;
5300
$labels = $lnspace x 26;
5301
$fmode &= ~($changemode|$firstopmode);
5302
apparentSize();
5303
return 1;
5304
}
5305
}
5306
$errorMsg = "nothing to strip";
5307
return 0;
5308
} # stripChild
5309
5310
sub sameChildLine($$$$)
5311
{
5312
my ($m1, $l1, $m2, $l2) = @_;
5313
my $t1 = $text[substr($$m1, $l1*$lnwidth, $lnwidth1)];
5314
my $t2 = $text[substr($$m2, $l2*$lnwidth, $lnwidth1)];
5315
removeHiddenNumbers \$t1;
5316
removeHiddenNumbers \$t2;
5317
$t1 =~ y/a-zA-Z0-9//cd;
5318
$t2 =~ y/a-zA-Z0-9//cd;
5319
return ($t1 eq $t2);
5320
} # sameChildLine
5321
5322
sub unstripChild()
5323
{
5324
$fmode&$browsemode or
5325
$errorMsg = $nobrowse, return 0;
5326
my $dol2 = $$btags[0]{dol2};
5327
$dol2 > $dol or $errorMsg = "nothing stripped from this web page", return 0;
5328
# Backing out.
5329
$map = $$btags[0]{map2};
5330
$fmode &= ~$firstopmode;
5331
$labels = $lnspace x 26;
5332
$dot = 1;
5333
$dol = $dol2;
5334
apparentSize();
5335
return 1;
5336
} # unstripChild
5337
5338
# Returns the index of the input field to be modified.
5339
# Sets $inf to the text of that field.
5340
# Sets $itag, $isize, and the other globals that establish an input field.
5341
# Returns 0 for no input fields on the line, -1 for some other error.
5342
sub infIndex($$)
5343
{
5344
my ($ln, $line) = @_;
5345
my ($i, $j, $idx);
5346
my @fields = ();
5347
my @fieldtext = ();
5348
# Here's some machinery to remember the index if there's only one
5349
# input field of the desired type.
5350
my $holdInput = 0;
5351
my $t = fetchLine $ln, 0;
5352
# Bug in perl mandates the use of the no-op (?=) below.
5353
# You'll see this other places in the code too.
5354
# This bug was fixed in September 2001, patch 12120.
5355
while($t =~ /\x80([\x85-\x8f]+)<(.*?)(?=)\x80\x8f>/g) {
5356
$j = revealNumber $1;
5357
$i = $2;
5358
push @fields, $j;
5359
push @fieldtext, $i;
5360
$itag = $$btags[$j];
5361
$itype = $$itag{type};
5362
next if $itype eq "area";
5363
if($line =~ /^\d*\*/) {
5364
if($itype eq "submit" or $itype eq "reset") {
5365
$holdInput = -1 if $holdInput > 0;
5366
$holdInput = $#fields+1 if $holdInput == 0;
5367
}
5368
} else {
5369
if($itype ne "submit" and $itype ne "reset") {
5370
$holdInput = -1 if $holdInput > 0;
5371
$holdInput = $#fields+1 if $holdInput == 0;
5372
}
5373
}
5374
}
5375
$j = $#fields + 1;
5376
if(!$j) {
5377
$errorMsg = "no input fields present" if ! $inglob;
5378
return 0;
5379
}
5380
$idx = -1;
5381
$idx = $1 if $line =~ /^(\d+)/;
5382
$idx = $holdInput if $holdInput > 0 and $idx < 0;
5383
$idx >= 0 or $j == 1 or
5384
$errorMsg = "multiple input fields, please use $icmd [1,$j]", return -1;
5385
$idx = 1 if $idx < 0;
5386
if($idx == 0 or $idx > $j) {
5387
$errorMsg = $j > 1 ?
5388
"invalid field, please use $icmd [1,$j]" :
5389
"line only has one input field";
5390
return -1;
5391
}
5392
$j = $fields[$idx-1];
5393
$inf = $fieldtext[$idx-1];
5394
$ifield = $idx;
5395
$itagnum = $j;
5396
$itag = $$btags[$j];
5397
$iline = $ln;
5398
$itype = $$itag{type};
5399
$isize = $$itag{size};
5400
$irows = $$itag{rows};
5401
$icols = $$itag{cols};
5402
$iwrap = $$itag{wrap};
5403
$iwrap = "" if ! defined $iwrap;
5404
$iwrap = lc $iwrap;
5405
$iopt = $$itag{opt};
5406
return $idx;
5407
} # infIndex
5408
5409
# Get status on an input field, including its options.
5410
sub infStatus($)
5411
{
5412
my $line = shift;
5413
$line =~ s/^\d*\?//;
5414
$line = lc $line;
5415
print $itype;
5416
print "[$isize]" if $isize;
5417
if($itype eq "area" and $irows and $icols) {
5418
print "[${irows}x$icols";
5419
print " recommended" if $iwrap eq "virtual";
5420
print "]";
5421
}
5422
print " many" if defined $$itag{multiple};
5423
print " <$inf>";
5424
my $name = $$itag{name};
5425
print " [$name]" if defined $name and length $name;
5426
print "\n";
5427
return unless $itype eq "select";
5428
5429
# Display the options in a pick list.
5430
# If a string is given, display only those options containing the string.
5431
my $i = 0;
5432
my @pieces = ();
5433
my $j;
5434
foreach my $v (%{$iopt}) {
5435
$i ^= 1;
5436
$j = $v, next if $i;
5437
$_ = $v;
5438
next unless s/^(...)[-+]//;
5439
next if length $line and index(lc $j, $line) < 0;
5440
push @pieces, "$1$j\n";
5441
}
5442
if($#pieces < 0) {
5443
print(length($line) ? "No options contain the string \"$line\"\n" :
5444
"No options found\n");
5445
return;
5446
}
5447
foreach (sort @pieces) {
5448
print((substr($_, 0, 3) + 1) . ": " . substr($_, 3));
5449
last if $intFlag;
5450
}
5451
} # infStatus
5452
5453
# Replace an input field with new text.
5454
sub infReplace($)
5455
{
5456
my $newtext = shift;
5457
my ($i, $j, $k, $t);
5458
5459
# Sanity checks on the input.
5460
$itype ne "submit" and $itype ne "reset" or
5461
$errorMsg = "field is a $itype button, use * to push the button", return 0;
5462
$itype ne "area" or
5463
$errorMsg = "field is a text area, you must edit it from another session", return 0;
5464
not defined $$itag{readonly} or
5465
$errorMsg = "readonly field", return 0;
5466
$newtext =~ /\n/ and
5467
$errorMsg = "input field cannot contain a newline character", return 0;
5468
return 0 if lineLimit 2;
5469
5470
if($ifield) {
5471
my $newlen = length $newtext;
5472
! $isize or $newlen <= $isize or
5473
$errorMsg = "input field too long, limit $isize", return 0;
5474
5475
if($itype eq "checkbox" or $itype eq "radio") {
5476
$newtext eq "+" or $newtext eq "-" or
5477
$errorMsg = "field requires + (active) or - (inactive)", return 0;
5478
$itype eq "checkbox" or $newtext eq '+' or $inf eq '-' or
5479
$errorMsg = "at least one radio button must be set", return 0;
5480
}
5481
} # not from reset button
5482
5483
if($itype eq "select") {
5484
my @opts = $newtext;
5485
@opts = split(',', $newtext) if defined $$itag{multiple};
5486
$newtext = "";
5487
option:
5488
foreach my $newopt (@opts) {
5489
$newtext .= "," if length $newtext;
5490
$j = $$iopt{$newopt};
5491
# If you type in the option exactly, that's grand.
5492
$newtext .= $newopt, next if defined $j and length $j;
5493
# Maybe it's a menu number.
5494
if($newopt =~ /^\d+$/) {
5495
$j = sprintf("%03d", $newopt-1);
5496
# reverse hash lookup.
5497
my $revcnt = 0;
5498
my $revkey;
5499
foreach (%{$iopt}) {
5500
$revcnt ^= 1;
5501
$revkey = $_, next if $revcnt;
5502
next unless substr($_, 0, 3) eq $j;
5503
$newtext .= $revkey;
5504
next option;
5505
}
5506
} else { # menu number conversion
5507
# See if this text is a piece of one and only one option.
5508
# Or if it is exactly one and only one option.
5509
$j = lc $newopt;
5510
my $matchCount = 0;
5511
my $matchLevel = 0;
5512
my $bestopt = "";
5513
foreach $k (keys %{$iopt}) {
5514
my $klow = lc $k; # k lower case
5515
next unless index($klow, $j) >= 0;
5516
if($j eq $klow) {
5517
$matchCount = 0, $matchLevel = 2 if $matchLevel < 2;
5518
++$matchCount;
5519
$bestopt = $k;
5520
} else {
5521
next if $matchLevel == 2;
5522
$matchCount = 0, $matchLevel = 1 unless $matchLevel;
5523
++$matchCount;
5524
$bestopt = $k;
5525
}
5526
}
5527
$newtext .= $bestopt, next option if $matchCount == 1;
5528
$errorMsg = "$j matches more than one entry in the list", return 0 if $matchCount > 1;
5529
}
5530
$errorMsg = "$newopt is not an option, type i$ifield? for the list";
5531
return 0;
5532
} # loop over options in the new list
5533
} # select
5534
5535
# Definitely making a change.
5536
$fmode |= $firstopmode;
5537
$ubackup = 1;
5538
$dot = $iline;
5539
5540
return 1 if $newtext eq $inf; # no change
5541
5542
# Find and replace the text.
5543
$t = fetchLine $iline, 0;
5544
my $itaghidden = hideNumber $itagnum;
5545
$t =~ s/\x80$itaghidden<.*?(?=)\x80\x8f>/\x80$itaghidden<$newtext\x80\x8f>/;
5546
push @text, $t;
5547
substr($map, $iline*$lnwidth, $lnwidth) =
5548
sprintf $lnformat, $#text;
5549
5550
if($itype eq "radio") { # find and undo the other radio button
5551
my $radioname = $$itag{name};
5552
if(defined $radioname and length $radioname) {
5553
my $form = $$itag{form};
5554
lineloop:
5555
foreach $k (1..$dol) {
5556
$t = fetchLine $k, 0;
5557
while($t =~ /\x80([\x85-\x8f]+)<\+\x80\x8f>/g) {
5558
$jh = $1;
5559
$j = revealNumber $1;
5560
next if $j == $itagnum; # already changed this one
5561
my $h = $$btags[$j];
5562
next unless $$h{form} eq $form;
5563
# Input field is part of our form.
5564
next unless $$h{type} eq "radio";
5565
my $name = $$h{name};
5566
next unless defined $name and $name eq $radioname;
5567
# It's another radio button in our set.
5568
$t =~ s/\x80$jh<\+\x80\x8f>/\x80$jh<-\x80\x8f>/;
5569
push @text, $t;
5570
substr($map, $k*$lnwidth, $lnwidth) =
5571
sprintf $lnformat, $#text;
5572
last lineloop;
5573
} # loop over input fields on this line
5574
} # loop over lines
5575
} # radio button has a name
5576
} # radio
5577
5578
return 1;
5579
} # infReplace
5580
5581
# Push the submit or reset button.
5582
sub infPush()
5583
{
5584
my $button = $itag;
5585
my $buttontype = $itype;
5586
$buttontype eq "submit" or $buttontype eq "reset" or
5587
$errorMsg = "this is not a submit or reset button", return 0;
5588
$cmd = 'b'; # this has become a browse command
5589
my $formh = $$itag{form};
5590
defined $formh or
5591
$errorMsg = "field is not part of a form", return 0;
5592
my $buttonvalue = $inf;
5593
$buttonvalue =~ s/ secure$//;
5594
$buttonvalue =~ s/ mailform$//;
5595
$buttonvalue =~ s/ js$//;
5596
my $domail = 0; # sendmail link
5597
5598
my $bref = $$formh{bref};
5599
my $action = $$formh{action};
5600
if(! defined $action or ! length $action) {
5601
# If no form program is specified, the default is the current url.
5602
$action = $bref;
5603
$action =~ s/\?.*//;
5604
}
5605
$domail = 1 if $action =~ s/^mailto://i;
5606
# We should check for $form{encoding}.
5607
5608
my ($name, $val, $i, $j, $cx, $h, @pieces);
5609
my $post = "";
5610
my $origdot = $dot;
5611
5612
# Loop over all tags, keeping those in the input form.
5613
$itagnum = -1;
5614
foreach $h (@$btags) {
5615
++$itagnum;
5616
next unless $$h{tag} eq "input";
5617
# Overwrite the global input variables, so infReplace will work properly.
5618
# $itagnum is already set.
5619
$itag = $h;
5620
$itype = $$h{type};
5621
$j = $$h{form};
5622
next unless defined $j and $j eq $formh;
5623
# Input field is part of our form.
5624
$iopt = $$h{opt};
5625
$isize = $$h{size};
5626
5627
if($itag eq $button and $itype eq "submit") {
5628
$name = $$button{name};
5629
if(defined $name and length $name) {
5630
if($domail) {
5631
$post .= "\n" if length $post;
5632
} else {
5633
$post .= '&' if length $post;
5634
$name = urlEncode $name;
5635
}
5636
if($$button{image}) {
5637
$post .= $domail ?
5638
"$name.x=\n0\n\n$name.y=\n0\n" :
5639
"$name.x=0&$name.y=0";
5640
} else {
5641
if(defined $buttonvalue and length $buttonvalue) {
5642
if($domail) {
5643
$post .= "$name=\n$buttonvalue\n";
5644
} else {
5645
$buttonvalue = urlEncode $buttonvalue;
5646
$post .= "$name=$buttonvalue";
5647
}
5648
} else {
5649
$post .= $domail ?
5650
"$name=\nSubmit\n" :
5651
"$name=Submit";
5652
}
5653
}
5654
}
5655
} # submit button
5656
5657
next if $itype eq "reset" or $itype eq "submit";
5658
5659
if($itype eq "hidden") {
5660
$inf = $$h{value};
5661
$iline = $ifield = 0;
5662
} else {
5663
# Establish the line number, field number, and field value.
5664
# This is crude and inefficient, but it doesn't happen very often.
5665
findField:
5666
for($iline=1; $iline<=$dol; ++$iline) {
5667
$j = fetchLine $iline, 0;
5668
$ifield = 0;
5669
while($j =~ /\x80([\x85-\x8f]+)<(.*?)(?=)\x80\x8f>/g) {
5670
$i = revealNumber $1;
5671
$inf = $2;
5672
++$ifield;
5673
last findField if $i == $itagnum;
5674
}
5675
}
5676
$iline <= $dol or $errorMsg = "input field $itagnum is lost", return 0;
5677
}
5678
5679
if($buttontype eq "submit") {
5680
if($itype eq "area") {
5681
$cx = $$h{cx};
5682
$val = "";
5683
if(defined $factive[$cx] and $dol[$cx]) {
5684
# Send all the lines of text in the secondary buffer.
5685
for(my $ln=1; $ln<=$dol[$cx]; ++$ln) {
5686
$val .= fetchLineContext($ln, 1, $cx);
5687
next if $ln == $dol[$cx];
5688
$val .= ($textAreaCR ? $eol : "\n");
5689
}
5690
}
5691
} else { # text area or field
5692
$val = $inf;
5693
if($itype eq "radio" or $itype eq "checkbox") {
5694
next if $val eq '-';
5695
$val = $$h{saveval};
5696
# I thought it had to say "on"; now I'm not sure.
5697
$val = "on" if $itype eq "checkbox" and ! length $val;
5698
} # radio
5699
} # text area or input field
5700
# Turn option descriptions into option codes for transmission
5701
if($itype eq "select") {
5702
@pieces = $val;
5703
@pieces = split ',', $val if defined $$h{multiple};
5704
$val = "";
5705
foreach (@pieces) {
5706
$val .= "," if length $val;
5707
my $code = $$iopt{$_};
5708
if(defined $code) {
5709
$code = substr($code, 4);
5710
} else {
5711
$code = $_;
5712
}
5713
$val .= $code;
5714
} # loop over options
5715
} # select
5716
5717
$name = $$h{name};
5718
defined $name or $name = "";
5719
if(! $domail) {
5720
# Encode punctuation marks for http transmition
5721
$name = urlEncode($name);
5722
$name .= '=';
5723
$val = urlEncode($val);
5724
}
5725
if($itype eq "select" and defined $$h{multiple}) {
5726
# This is kludgy as hell.
5727
# comma has been turned into %2C
5728
@pieces = split '%2C', $val;
5729
foreach $val (@pieces) {
5730
$post .= ($domail ? "\n" : '&') if length $post;
5731
$post .= $name;
5732
$post .= "\n" if $domail and length $name;
5733
$post .= $val;
5734
$post .= "\n" if $domail and length $val;
5735
}
5736
} else {
5737
$post .= ($domail ? "\n" : '&') if length $post;
5738
$post .= $name;
5739
$post .= "\n" if $domail and length $name;
5740
$post .= $val;
5741
$post .= "\n" if $domail and length $val;
5742
}
5743
5744
} else { # submit or reset
5745
5746
next if $itype eq "hidden";
5747
if($itype eq "area") {
5748
$cx = $$h{cx};
5749
cxReset($cx, 2);
5750
$factive[$cx] = 1;
5751
} else {
5752
$ifield = 0; # zero skips some of the field checks in infReplace
5753
$val = $$h{value};
5754
infReplace($val);
5755
} # field or text area
5756
5757
} # submit or reset
5758
} # loop over tags
5759
5760
$dot = $origdot, return 1 if $buttontype eq "reset";
5761
print "submit: $post\n" if $debug >= 2;
5762
5763
length $action or
5764
$errorMsg = "form does not specify a program to run", return 0;
5765
5766
if($domail) {
5767
my $subj = urlSubject(\$action);
5768
$subj = "html form" unless length $subj;
5769
$post = "Subject: $subj\n\n$post";
5770
print "$action\n";
5771
my @tolist = ($action);
5772
my @atlist = ();
5773
$mailToSend = "form";
5774
$altattach = 0;
5775
$whichMail = $localMail;
5776
sendMail(\@tolist, \$post, \@atlist) or return 0;
5777
print "Form has been mailed, watch for a reply.\n";
5778
return 1;
5779
} # sendmail
5780
5781
$line = resolveUrl($bref, $action);
5782
print "* $line\n";
5783
$post = ($$formh{method} eq "get" ? '?' : '*') . $post;
5784
return -1, $line, $post;
5785
} # infPush
5786
5787
sub renderMail($)
5788
{
5789
my $tbuf = shift;
5790
$badenc = $bad64 = 0;
5791
$fhLevel = 0;
5792
$nat = 0; # number of attachments
5793
@mimeParts = ();
5794
5795
# Copy lines into @msg.
5796
# The original cleanMail routine was built upon @msg,
5797
# And when I folded it into edbrowse, I was too lazy to change it.
5798
@msg = ();
5799
push @msg, fetchLine($_, 0) foreach (1..$dol);
5800
5801
findHeaders(0, $#msg);
5802
deGreater();
5803
nullForwarding();
5804
--$#msg while $#msg >= 0 and
5805
$msg[$#msg] !~ /[a-zA-Z0-9]/;
5806
5807
# Last chance to interrupt a browse operation
5808
$errorMsg = $intMsg, return 0 if $intFlag;
5809
5810
$$tbuf = "";
5811
$$tbuf .= "$_\n" foreach (@msg);
5812
chomp $$tbuf if length $$tbuf;
5813
$$tbuf =~ y/\x92\x93\x94\xa0\xad/'`' -/;
5814
return 1;
5815
} # renderMail
5816
5817
# Insert this text line between mail headers.
5818
$mailBreak = "{NextMailHeader}";
5819
# Insert this text line between mime headers.
5820
$mimeBreak = "{NextMimeSection}, Level";
5821
# Max lines in a "to unsubscribe" trailer?
5822
$unsHorizon = 7;
5823
5824
# Hash the annoying commercials.
5825
%annoy = ();
5826
if(length $annoyFile) {
5827
open FH, $annoyFile
5828
or dieq "Cannot open file of annoying commercials $annoyFile.";
5829
while(<FH>) {
5830
stripWhite \$_;
5831
$annoy{lc $_} = "" if length $_;
5832
}
5833
close FH;
5834
} # annoy
5835
5836
# Today timestamp, so old "junk" subjects can expire.
5837
$junkToday = int time / (60*60*24);
5838
$junkHorizon = 14;
5839
$oldSubjects = 0;
5840
%junkSubjects = ();
5841
5842
# Now load the junk subjects, which we aren't interested in reading.
5843
if(length $junkFile) {
5844
open FH, $junkFile
5845
or dieq "Cannot open file of junk subjects $junkFile.";
5846
while(<FH>) {
5847
s/\n$//; # don't need nl
5848
($jtime = $_) =~ s/:.*//;
5849
($jsubject = $_) =~ s/^\d+:\s*(.*)\s*$/$1/;
5850
if($jsubject =~ /^`/) {
5851
$junkSubjects{$jsubject} = $junkToday;
5852
} else {
5853
$oldSubjects = 1, next if $jtime < $junkToday - $junkHorizon;
5854
$junkSubjects{$jsubject} = $jtime;
5855
}
5856
}
5857
close FH;
5858
} # junkFile
5859
5860
# Add a subject to the junk list.
5861
# This updates the junk file.
5862
sub markSubject ($)
5863
{
5864
my $s = shift;
5865
die "No subject to junk." if $s eq "";
5866
$junkSubjects{$s} = $junkToday;
5867
if($oldSubjects) {
5868
open FH, ">$junkFile"
5869
or dieq "Cannot rewrite file of junk subjects $junkFile.";
5870
$iskey = 0;
5871
foreach (%junkSubjects) {
5872
($iskey ^= 1) ?
5873
($savekey = $_) :
5874
print FH "$_:$savekey\n";
5875
}
5876
$oldSubjects = 0;
5877
} else {
5878
open FH, ">>$junkFile"
5879
or dieq "Cannot add to file of junk subjects $junkFile.";
5880
print FH "$junkToday:$s\n";
5881
}
5882
close FH;
5883
} # markSubject
5884
5885
# Build an array for base64 decoding.
5886
{
5887
my ($j, $c);
5888
$c = 'A', $j = 0;
5889
$b64_map[ord $c] = $j, ++$c, ++$j until $j == 26;
5890
$c = 'a';
5891
$b64_map[ord $c] = $j, ++$c, ++$j until $j == 52;
5892
$c = '0';
5893
$b64_map[ord $c] = $j, ++$c, ++$j until $j == 62;
5894
$b64_map[ord '+'] = $j++;
5895
$b64_map[ord '/'] = $j++;
5896
}
5897
5898
# The following routine decodes the Quoted-Printable mime standard.
5899
# If one line ends in an equals sign, it must be joined to the next.
5900
# All other =xx sequences become the 8-bit value defined by hex xx.
5901
# Pass the start and end offsets -- what do you want to dequote?
5902
# Also pass the boundary, if any, and stop there.
5903
sub qp_lowlevel($$$)
5904
{
5905
my ($start, $end, $boundary) = @_;
5906
print "qp $start-$end<$boundary\n" if $debug >= 6;
5907
return if $end < $start;
5908
5909
my $tbuf = "";
5910
foreach my $i ($start..$end) {
5911
if(length $boundary) {
5912
my $line = $msg[$i];
5913
$line =~ s/^[ \t>]*-*//;
5914
$line =~ s/-*$//;
5915
$end = $i-1, last if $line eq $boundary;
5916
}
5917
$msg[$i] =~ s/[ \t]+$//;
5918
$tbuf .= $msg[$i]."\n";
5919
}
5920
chomp $tbuf;
5921
print "qp ends at $end, length " . length($tbuf) . "\n" if $debug >= 6;
5922
5923
# Now undo quoted-printable encoding.
5924
# Use global substitutions on the concatenated texts, it's faster.
5925
my $join =
5926
$tbuf =~ s/=\n//g;
5927
$join = 0 unless $join;
5928
print "qp joins $join lines\n" if $debug >= 6;
5929
$tbuf =~ s/=([0-9a-fA-F]{2})/chr hex "$1"/ge;
5930
# Split the text back into lines, and back into @msg.
5931
$end -= $join;
5932
if(length $tbuf) {
5933
@msg[$start.. $end] = split("\n", $tbuf, $end-$start+1);
5934
} else { # split problem
5935
$msg[$start] = ""; # probably was "" already
5936
}
5937
# Fill the empty spaces with blank lines
5938
$msg[++$end] = '' while $join--;
5939
} # qp_lowlevel
5940
5941
# If the message includes any lines with leading > signs,
5942
# break paragraphs whenever the nesting level changes.
5943
# A change in the number of > symbols indicates a different speaker,
5944
# hence a new paragraph.
5945
# But watch out!
5946
# Some mail intermediaries cut long lines,
5947
# leaving a dangling fragment without a > nesting level.
5948
# This fragment does not represent a new paragraph;
5949
# it is part of the previous sentence.
5950
# But watch watch out!
5951
# Some people deliberately interject short comments, as in:
5952
#
5953
# > I really think the Tigers are the hotest baseball team ever, really great,
5954
# Horse feathers!
5955
# > a team to look up to.
5956
#
5957
# There is virtually no way to distinguish between the two cases.
5958
# Most of the time a short fragment in the midst of indented text
5959
# actually belongs to the previous line,
5960
# so I treat it as such and hope for the best.
5961
sub deGreater()
5962
{
5963
my (@nestlev, @newmsg, $i, $j, $state, $temp);
5964
my $lastsubject = "";
5965
5966
# Push some blank lines, to avoid eof conditions.
5967
push @msg, '', '', '';
5968
5969
# Establish the nest level of each line.
5970
foreach (@msg) {
5971
$temp = $_;
5972
# Count > signs.
5973
$temp =~ s/^([ \t>]*).*/$1/;
5974
$j = $temp =~ y/>/>/;
5975
push @nestlev, $j;
5976
}
5977
5978
my $lastlev = 0;
5979
my $newlev;
5980
for($i=0; $i<=$#msg; ++$i) {
5981
$newlev = $nestlev[$i];
5982
5983
# Let's get right at the tricky part, a drop in level.
5984
# It's a fragment if the next line, or line after,
5985
# has the same nest level as the previous line.
5986
if($newlev < $lastlev and
5987
(($nextlev = $nestlev[$i+1]) == $lastlev or
5988
$nextlev < $lastlev && $nestlev[$i+2] == $lastlev)) {
5989
$temp = $msg[$i];
5990
$temp =~ s/^[ \t>]*//;
5991
if($j = length $temp) {
5992
if($nextlev == $lastlev) {
5993
$newmsg[$#newmsg] .= " $temp";
5994
next;
5995
}
5996
# It must be that the line after next has the previous nest level.
5997
my $temp2 = $msg[$i+1];
5998
$temp2 =~ s/^[ \t>]*//;
5999
if($j = length $temp2) {
6000
$newmsg[$#newmsg] .= " $temp $temp2";
6001
++$i;
6002
next;
6003
} # next line is nonempty
6004
} # this line is nonempty
6005
6006
$newlev = $lastlev if $j == 0 and $nextlev == $lastlev;
6007
} # bracketed between larger nest levels
6008
6009
if($msg[$i] =~ /^$mailBreak/o) {
6010
$newlev = $ lastlev = 0;
6011
push @newmsg, $mailBreak;
6012
my ($subject, $from, $date, $reply);
6013
$temp = $msg[$i];
6014
($subject = $temp) =~ s/\n.*//s if $temp =~ s/.*\nSubject: //s;
6015
($from = $temp) =~ s/\n.*//s if $temp =~ s/.*\nFrom: //s;
6016
($date = $temp) =~ s/\n.*//s if $temp =~ s/.*\nDate: //s;
6017
($reply = $temp) =~ s/\n.*//s if $temp =~ s/.*\nReply-to: //s;
6018
if(defined $subject or defined $from or defined $date or defined $reply) {
6019
if($#newmsg == 0) { # Read the first header differently.
6020
push @newmsg, "Subject: $subject" if defined $subject;
6021
push @newmsg, "From $from" if defined $from;
6022
} else {
6023
$temp = "Message";
6024
if(defined $from) {
6025
$temp .= " from $from,";
6026
if(defined $subject) {
6027
$temp .= (
6028
$subject eq $lastsubject ?
6029
" same subject." :
6030
" with subject, $subject.");
6031
} else {
6032
$temp .= " with no subject.";
6033
} # subject or not
6034
} else {
6035
if(defined $subject) {
6036
$temp .= (
6037
$subject eq $lastsubject ?
6038
" with the same subject." :
6039
" with subject, $subject.");
6040
} else {
6041
$temp .= " with no subject.";
6042
} # subject or not
6043
} # from line or not
6044
push @newmsg, $temp;
6045
} # top header or internal
6046
push @newmsg, "Mail sent $date" if defined $date;
6047
push @newmsg, "Reply to $reply" if defined $reply;
6048
push @newmsg, "" if $#newmsg;
6049
}
6050
$subject = "" if ! defined $subject;
6051
$lastsubject = $subject;
6052
next;
6053
} # mail header
6054
6055
if($newlev != $lastlev) {
6056
push @newmsg, "", "Indent $newlev.";
6057
} # change in level
6058
6059
# Strip off leading >
6060
$temp = $msg[$i];
6061
$temp =~ s/^[ \t]*>[ \t>]*//;
6062
push @newmsg, $temp;
6063
$lastlev = $newlev;
6064
} # loop over lines
6065
6066
# Push a mime separater on, to make the unsubscribe test work.
6067
push @newmsg, "$mimeBreak 1";
6068
6069
# Now put the lines back into @msg, compressing blank lines.
6070
# Also, Try to remove any "unsubscribe" trailers.
6071
$#msg = -1;
6072
my $unslast = -1;
6073
my $unscount = 0;
6074
my $unstest;
6075
$state = 1;
6076
$j = 0;
6077
6078
foreach my $line (@newmsg) {
6079
# Check for "to unsubscribe"
6080
if($line =~ /^ *to unsubscribe/i) {
6081
$unslast = $j if $unslast < 0 or $unscount > $unsHorizon;
6082
$unscount = 0;
6083
} # unsubscribe line
6084
6085
# Check for mime/mail separater.
6086
$unstest = 0;
6087
$temp = lc $line;
6088
$temp =~ s/\s+$//;
6089
if($line =~ /^$mimeBreak \d/o or
6090
$line eq $mailBreak or
6091
defined $annoy{$temp} or
6092
$temp =~ /^-+\s*original message\s*-+\s*$/) {
6093
$line = ""; # no need to read that
6094
$unstest = 1;
6095
}
6096
6097
$unstest = 1 if $line =~ /^$mailBreak/o;
6098
6099
if($line =~ /^Indent \d/) {
6100
$unstest = 1;
6101
if($j > 0 and $msg[$j-1] =~ /^Indent \d/) {
6102
--$j, --$#msg;
6103
$unstest = 0;
6104
} # sequential indents
6105
} # indent line
6106
6107
if($unstest and $unslast >= 0 and $unscount <= $unsHorizon) {
6108
# Remove unsubscribe section
6109
$j = $unslast - 1;
6110
$unslast = -1;
6111
--$j while $j >= 0 and
6112
$msg[$j] !~ /[a-zA-Z0-9]/;
6113
$#msg = $j;
6114
++$j;
6115
$state = ($j == 0);
6116
next;
6117
} # crunching unsubscribe
6118
6119
if(length $line) {
6120
++$unscount if $line =~ /[a-zA-Z0-9]/;
6121
$msg[$j++] = $line;
6122
$state = 0;
6123
$state = 1 if $line =~ /^Indent \d/;
6124
} elsif(! $state) {
6125
$msg[$j++] = $line;
6126
$state = 1;
6127
}
6128
} # loop over lines
6129
6130
--$j;
6131
--$j if $j >= 0 and $state;
6132
$#msg = $j;
6133
} # deGreater
6134
6135
# No need to read vacuous forwardings.
6136
sub nullForwarding()
6137
{
6138
my $lf = -1; # last forwarding
6139
my $j = 0;
6140
foreach my $line (@msg) {
6141
if($line =~ /^Message/) {
6142
$j = $lf if $lf >= 0 and $j - $lf <= 4;
6143
$lf = $j;
6144
}
6145
$msg[$j++] = $line;
6146
} # loop over lines
6147
--$j;
6148
$#msg = $j;
6149
} # nullForwarding
6150
6151
# Decide whether a line, and eventually a paragraph, is an email header.
6152
# Realize that these headers might be pasted in almost anywhere.
6153
# They don't always appear at the top of the message,
6154
# or even the top of a mime section.
6155
# They may even be indented, or prepended with leading greater than signs,
6156
# if a mail message is manually forwarded, or pasted inside a larger
6157
# mail message.
6158
# We willhowever assume that a header block, once begun,
6159
# continues until we reach a blank line.
6160
# If you've manually pasted a header and body together, sorry,
6161
# but the body is going to get thrown away.
6162
# This routine is recursive, so make sure the appropriate variables are auto.
6163
# Pass the start and end offsets -- a sub-message inside the entire message.
6164
sub findHeaders($$) ;
6165
sub findHeaders($$)
6166
{
6167
my ($start, $end) = @_;
6168
++$fhLevel;
6169
my $startLine = -1;
6170
my $boundaryCut = "";
6171
my ($i, $j, $temp, $line, $state);
6172
my ($reply, $from, $subject, $date);
6173
my ($boundary, $content, $encoding, $encfile);
6174
my $expand64 = 0;
6175
6176
$line = $msg[$start];
6177
if($line =~ s/^$mailBreak.*\nboundary=//so) {
6178
$line =~ s/\n$//;
6179
$boundaryCut = $line;
6180
}
6181
6182
print "findheaders$fhLevel $start-$end<$boundaryCut\n" if $debug >= 6;
6183
6184
foreach $i ($start..$end) {
6185
$line = $msg[$i];
6186
6187
# Strip away whitespace and leading greater than signs.
6188
$line =~ s/^[ \t>]+//;
6189
$line =~ s/\s+$//;
6190
6191
# Are we expanding binary data?
6192
if($expand64) {
6193
$expand64 = 0 if $line eq "";
6194
if(length $boundaryCut and $expand64) {
6195
$temp = $line;
6196
$temp =~ s/^-+//;
6197
$temp =~ s/-+$//;
6198
$expand64 = 0 if $temp eq $boundaryCut;
6199
}
6200
if($expand64) {
6201
my ($c, $leftover, $rem);
6202
# We don't really need the padding equals to run the algorithm properly.
6203
# Sometimes it ends in =9 I don't know what that means!
6204
$line =~ s/=+9*$//;
6205
if($line =~ y;+/a-zA-Z0-9;;cd && !$bad64) {
6206
warn "Invalid base64 encoding at line $i";
6207
$bad64 = 1;
6208
}
6209
for($j=0; $j < length $line; ++$j) {
6210
$c = $b64_map[ord substr($line,$j,1)];
6211
$rem = $j & 3;
6212
if($rem == 0) {
6213
$leftover = $c<<2;
6214
} elsif($rem == 1) {
6215
$$curPart{data} .= chr($leftover | ($c>>4));
6216
$leftover = ($c & 0xf) <<4;
6217
} elsif($rem == 2) {
6218
$$curPart{data} .= chr($leftover | ($c>>2));
6219
$leftover = ($c & 3) <<6;
6220
} else {
6221
$$curPart{data} .= chr($leftover | $c);
6222
}
6223
}
6224
$msg[$i] = "";
6225
next;
6226
}
6227
}
6228
6229
# Look for mailKeyWord:
6230
# We check for a header until we have established a boundary,
6231
# and then we only crack the header at the start of each section.
6232
if(($startLine >= 0 or # inside a header
6233
! length $boundaryCut or # no boundary yet
6234
$msg[$i-1] eq "$mimeBreak $fhLevel") # top of the mime section
6235
and
6236
$line =~ /^\$?[a-zA-Z][\w-]*:/) { # keyword:
6237
if($startLine < 0) {
6238
$startLine = $i;
6239
$state = 0;
6240
$reply = $from = $subject = $date = "";
6241
$boundary = $content = $encoding = $encfile = "";
6242
}
6243
($headKey = $line) =~ s/:.*//;
6244
$headKey = lc $headKey;
6245
($headVal = $line) =~ s/^[^:]+:\s*//;
6246
my $headKeyType = $mhWords{$headKey};
6247
$state |= $headKeyType if defined $headKeyType;
6248
if($headVal ne "") {
6249
$from = $headVal if $headKey eq "from";
6250
$reply = $headVal if $headKey eq "reply-to";
6251
$subject = $headVal if $headKey eq "subject";
6252
$date = $headVal if $headKey eq "date";
6253
$date = $headVal if $headKey eq "sent";
6254
if($headKey eq "content-transfer-encoding") {
6255
$encoding = lc $headVal;
6256
}
6257
if($headKey eq "content-type") {
6258
$content = lc $headVal;
6259
$content =~ s/;.*//;
6260
}
6261
} # something after keyword:
6262
} # keyword: mail/mime header line
6263
6264
if($startLine >= 0) {
6265
# boundary= is a special attribute within a mail header
6266
$temp = $line;
6267
if($temp =~ s/.*boundary *= *//i) {
6268
($temp =~ s/^"//) ?
6269
($temp =~ s/".*//) :
6270
($temp =~ s/,.*//);
6271
$boundary = $temp;
6272
$boundary =~ s/^-+//;
6273
$boundary =~ s/-+$//;
6274
$boundaryCut = $boundary if length $boundary and ! length $boundaryCut;
6275
} # boundary keyword detected
6276
# filename is similarly set.
6277
$temp = $line;
6278
if($temp =~ s/.*(?:file)?name *= *//i) {
6279
($temp =~ s/^"//) ?
6280
($temp =~ s/".*//) :
6281
($temp =~ s/,.*//);
6282
$encfile = $temp;
6283
}
6284
6285
} else {
6286
6287
next if ! length $boundaryCut;
6288
# Strip away leading and trailing hyphens -- helps us look for boundary
6289
$line =~ s/^-+//;
6290
$line =~ s/-+$//;
6291
next if $line ne $boundaryCut;
6292
$msg[$i] = "$mimeBreak $fhLevel";
6293
next;
6294
} # body
6295
6296
# Now we know we're inside a mail header.
6297
next if length $line;
6298
6299
# We've got a blank line -- that ends the header.
6300
# But it's not really a header if we've just got English keywords.
6301
if($state&5) {
6302
6303
if(length $boundary) {
6304
# Skip the preamble.
6305
foreach $j ($i+1..$#msg) {
6306
$temp = $msg[$j];
6307
$temp =~ s/^-+//;
6308
$temp =~ s/-+$//;
6309
last if $temp eq $boundary;
6310
$msg[$j] = "";
6311
}
6312
}
6313
6314
# Handle the various encodings.
6315
$encoding = "" if length $boundary and $startLine == $start;
6316
$encoding = "" if $encoding eq "8bit" or $encoding eq "7bit" or $encoding eq "binary";
6317
if($encoding eq "quoted-printable") {
6318
qp_lowlevel($i+1, $end, $boundaryCut);
6319
$encoding = "";
6320
}
6321
if($encoding eq "base64") { # binary attachment
6322
$expand64 = 1;
6323
$curPart = { data => "", filename => $encfile, isattach => 1};
6324
push @mimeParts, $curPart;
6325
++$nat;
6326
$encoding = "";
6327
}
6328
if($encoding and !$badenc) {
6329
warn "Unknown encoding at line $i $encoding";
6330
$badenc = 1;
6331
}
6332
6333
$j = $startLine;
6334
if($state & 4 or length $boundary) {
6335
# Process from/reply lines.
6336
$reply = $from if ! length $reply;
6337
$from = $reply if ! length $from;
6338
$from =~ s/".*// if $from =~ s/^"//;
6339
$from =~ s/\s*<.*>.*$//;
6340
$reply =~ s/^.*<(.*)>.*$/$1/;
6341
$reply = ""
6342
if length $reply and (
6343
$reply =~ /[\s<>]/ or $reply !~ /\w@\w/ or $reply !~ /\w\.\w/);
6344
# Strip away re: and fwd:
6345
while($subject =~ s/^(re|fd|fwd)[,:]\s*//i) { }
6346
6347
$mailSubject = $subject,
6348
$mailFrom = $from,
6349
$mailReply = $reply,
6350
$mailDate = $date
6351
if $startLine == 0; # top of the message
6352
6353
# Consolodate the header.
6354
$line = "$mailBreak\n";
6355
$line .= "Subject: $subject\n" if length $subject;
6356
$line .= "From: $from\n" if length $from;
6357
$line .= "Date: $date\n" if length $date;
6358
$line .= "Reply-to: $reply\n" if length $reply;
6359
$line .= "boundary=$boundary\n" if length $boundary;
6360
$msg[$j++] = $line;
6361
} # mail header
6362
$msg[$j++] = "" while $j <= $i;
6363
6364
# Decode html, if specified in the header.
6365
# Or turn it into an attachment, if anything other than plain text.
6366
if(length $content and ! $expand64) {
6367
if($content eq "text/html" or length $encfile) {
6368
mailHtml($i+1, $end, $startLine-1, $boundaryCut, $encfile);
6369
$content = "text/plain";
6370
}
6371
}
6372
6373
} # mail or mime header
6374
6375
$startLine = -1;
6376
} # loop over lines in the message
6377
6378
if(length $boundaryCut) {
6379
# Still more work to do.
6380
# Reprocess each section.
6381
$boundary = "$mimeBreak $fhLevel";
6382
$j = -1;
6383
foreach $i ($start..$end) {
6384
next unless $msg[$i] eq $boundary;
6385
findHeaders($j+1, $i-1) if $j >= 0;
6386
$j = $i;
6387
} # loop over lines
6388
} # bounhdary encountered
6389
6390
--$fhLevel;
6391
} # findHeaders
6392
6393
# process an html mime section within a mail message.
6394
sub mailHtml($$$$$)
6395
{
6396
my ($start, $end, $breakLine, $boundary, $filename) = @_;
6397
return if $end < $start; # should never happen
6398
my ($i, $line);
6399
6400
my $tbuf = "";
6401
6402
foreach $i ($start..$end) {
6403
$line = $msg[$i];
6404
$line =~ s/^[ \t>]*//;
6405
6406
# boundary may end this section.
6407
if(length $boundary) {
6408
my $temp = $line;
6409
$temp =~ s/^-+//;
6410
$temp =~ s/-+$//;
6411
$end = $i-1, last if $temp eq $boundary;
6412
}
6413
6414
$tbuf .= "$line\n";
6415
$msg[$i] = "";
6416
} # loop over lines
6417
6418
if(length $filename) { # present as attachment
6419
$curPart = { data => $tbuf, filename => $filename, isattach => 1};
6420
push @mimeParts, $curPart;
6421
++$nat;
6422
return;
6423
}
6424
6425
my $cx = cxCreate(\$tbuf, $filename);
6426
my $precx = $context;
6427
cxSwitch $cx, 0;
6428
readyUndo();
6429
# $tbuf still holds the html attachment
6430
$badHtml = 1;
6431
renderHtml(\$tbuf) and
6432
pushRenderedText(\$tbuf);
6433
cxSwitch $precx, 0;
6434
6435
++$cx;
6436
print "switch to session $cx for the html version of this mail\n" unless $ismc;
6437
} # mailHtml
6438
6439
# Connect to the mail server.
6440
sub pop3connect($$)
6441
{
6442
my $remote = shift;
6443
my $port = shift;
6444
my $iaddr = inet_aton($remote) or
6445
$errorMsg = "cannot locate the mail server $remote", return 0;
6446
my $paddr = sockaddr_in($port, $iaddr);
6447
my $proto = getprotobyname('tcp');
6448
socket(SERVER_FH, PF_INET, SOCK_STREAM, $proto) or
6449
$errorMsg = "Cannot establish TCP socket", return 0;
6450
connect(SERVER_FH, $paddr) or
6451
$errorMsg = "Cannot connect to mail server $remote", return 0;
6452
SERVER_FH->autoflush(1);
6453
return 1;
6454
} # pop3connect
6455
6456
# Put and get lines from the mail server.
6457
sub serverPutLine ($)
6458
{
6459
my $line = shift;
6460
if($debug >= 7) {
6461
my $t = $line;
6462
$t =~ s/\r\n/\n/g;
6463
print "$t\n";
6464
}
6465
print SERVER_FH $line.$eol or
6466
$errorMsg = "Could not write to the mail socket", return 0;
6467
return 1;
6468
} # serverPutLine
6469
6470
sub serverGetLine()
6471
{
6472
defined($serverLine = <SERVER_FH>)
6473
or $errorMsg = "could not read from the mail socket", return 0;
6474
# strip trailing newline indicator(s)
6475
$serverLine =~ s/[\r\n]+$//;
6476
print "< $serverLine\n" if $debug >= 7;
6477
return 1;
6478
} # serverGetLine
6479
6480
sub serverClose($)
6481
{
6482
my $scheme = shift;
6483
# Should we make $scheme global instead of passing it around?
6484
if($scheme =~ /(smtp|pop3)/i) {
6485
serverPutLine("quit");
6486
} elsif ($scheme =~ /ftp/i) {
6487
serverPutLine "abor${eol}quit";
6488
# Nope, abor is not a typo.
6489
my @disposeOf = <SERVER_FH>;
6490
close FDFH if defined FDFH;
6491
close FLFH if defined FLFH;
6492
}
6493
sleep 2;
6494
close SERVER_FH;
6495
} # serverClose
6496
6497
# This subroutine was taken from MIME::Base64 by Gisle Aas.
6498
sub encodeBase64($$$)
6499
{
6500
my($in, $eol, $out) = @_;
6501
my $inl = length $$in;
6502
# uuencode is pretty close
6503
$$out = pack 'u', $$in;
6504
# get rid of first and last char
6505
$$out =~ s/^.//;
6506
chop $$out;
6507
# Get rid of newlines inside
6508
$$out =~ s/\n.//g;
6509
# Over to base 64 char set
6510
$$out =~ tr|` -_|AA-Za-z0-9+/|;
6511
# fix padding at the end
6512
my $padding = (3 - $inl%3) % 3;
6513
$$out =~ s/.{$padding}$/'=' x $padding/e if $padding;
6514
# break encoded string into lines of no more than 76 characters each
6515
if (length $eol) {
6516
$$out =~ s/(.{1,72})/$1$eol/g;
6517
}
6518
} # encodeBase64
6519
6520
# Read the file into memory, mime encode it,
6521
# and return the type of encoding and the encoded data.
6522
# Last three parameters are result parameters.
6523
sub encodeAttachment($$$$$)
6524
{
6525
my ($atfile, $isMail, $res_enc, $res_type, $res_data) = @_;
6526
my ($subline, $buffer, $fsize, $rsize);
6527
6528
if(!$isMail) {
6529
if($atfile =~ /^\d+$/) { # edbrowse session
6530
my $cx = $atfile - 1;
6531
$buffer = "";
6532
for(my $ln=1; $ln<=$dol[$cx]; ++$ln) {
6533
$buffer .= fetchLineContext($ln, 1, $cx);
6534
$buffer .= "\n" if $ln < $dol[$cx];
6535
}
6536
$fsize = $rsize = length $buffer;
6537
} else {
6538
open FH, $atfile or
6539
$errorMsg = "cannot open attachment file $atfile,$!", return 0;
6540
binmode FH, ':raw' if $doslike;
6541
$fsize = (stat(FH))[7];
6542
$rsize = 0;
6543
$buffer = "";
6544
$rsize = sysread(FH, $buffer, $fsize) if $fsize;
6545
close FH;
6546
$rsize == $fsize or
6547
$errorMsg = "cannot read the contents of $atfile,$!", return 0;
6548
}
6549
} else {
6550
$buffer = $$atfile;
6551
# We just made a copy of the mail to send; hope it wasn't too big.
6552
$atfile = $mailToSend;
6553
$fsize = $rsize = length $buffer;
6554
$buffer =~ s/^\s*subject\s*:\s*/Subject: /i or
6555
$errorMsg = "$atfile does not begin with a line `Subject: subject of your mail'", return 0;
6556
$buffer =~ s/\r\n/\n/g;
6557
$buffer .= "\n" if substr($buffer, -1) ne "\n";
6558
$buffer .= ':'; # temporary
6559
# Extra blank line after subject.
6560
$buffer =~ s/^(.*\n)(.)/$1\n$2/;
6561
$buffer =~ /^(.*)\n/;
6562
$subline = $1;
6563
substr($buffer, -1) = ""; # get rid of :
6564
length $subline < 90 or
6565
$errorMsg = "subject line too long, limit 80 characters", return 0;
6566
} # primary mail message
6567
6568
my $newbuf = "";
6569
my ($c, $col, $j, $ctype, $enc);
6570
6571
# Count nonascii characters.
6572
my $nacount = $buffer =~ y/\x80-\xff/\x80-\xff/;
6573
# Count null characters.
6574
my $nullcount = $buffer =~ y/\0/\0/;
6575
$nacount += $nullcount;
6576
6577
if($nacount*5 > $fsize and $fsize > 20) {
6578
! $isMail or
6579
$errorMsg = "cannot mail the binary file $atfile - perhaps this should be an attachment?", return 0;
6580
6581
encodeBase64(\$buffer, "\n", \$newbuf);
6582
6583
$ctype = "application/octet-stream";
6584
$ctype = "application/PostScript" if $atfile =~ /\.ps$/i;
6585
$ctype = "image/jpeg" if $atfile =~ /\.jpeg$/i;
6586
$ctype = "image/gif" if $atfile =~ /\.gif$/i;
6587
$ctype = "audio/basic" if $atfile =~ /\.wav$/i;
6588
$ctype = "video/mpeg" if $atfile =~ /\.mpeg$/i;
6589
$enc = "base64";
6590
$$res_type = $ctype;
6591
$$res_enc = $enc;
6592
$$res_data = $newbuf;
6593
return 1;
6594
} # base 64 encode
6595
6596
# Use the filename of the edbrowse session to determine type.
6597
if($atfile =~ /^\d+$/) {
6598
$atfile = $fname[$atfile-1];
6599
}
6600
$ctype = "text/plain";
6601
$ctype = "text/html" if $atfile =~ /\.(htm|html|shtml|asp)$/i;
6602
$ctype = "text/richtext" if $atfile =~ /\.rtf$/i;
6603
6604
# Switch to unix newlines - we'll switch back to dos later.
6605
$buffer =~ s/\r\n/\n/g;
6606
$fsize = length $buffer;
6607
6608
if($nacount*20 < $fsize) {
6609
# Looks like it's almost all ascii, but we still have to switch to qp
6610
# if the lines are too long.
6611
$col = 0;
6612
for($j =0; $j < $fsize; ++$j) {
6613
$c = substr $buffer, $j, 1;
6614
$col = 0, next if $c eq "\n";
6615
++$col;
6616
$nacount = $fsize, last if $col > 500 or $col > 120 and ! $isMail;
6617
}
6618
}
6619
6620
if($nullcount or $nacount*20 >= $fsize) {
6621
$buffer =~ s/([^\t\n-<>-~])/sprintf("=%02X", ord $1)/ge;
6622
$buffer =~ s/ $/=20/m;
6623
$buffer =~ s/\t$/=09/m;
6624
# Cut long lines, preferably after a space, but wherever we can.
6625
$fsize = length $buffer;
6626
my $spaceCol = 0;
6627
$col = 0;
6628
for($j =0; $j < $fsize; ++$j) {
6629
$c = substr $buffer, $j, 1;
6630
$newbuf .= $c;
6631
if($c eq "\n") { # new line, column 0
6632
$spaceCol = $col = 0;
6633
next;
6634
}
6635
++$col;
6636
if($c eq " " || $c eq "\t") {
6637
$spaceCol = length $newbuf;
6638
}
6639
next if $col < 72;
6640
# Don't break an = triplet.
6641
next if $c eq '=';
6642
next if substr($newbuf, -2, 1) eq '=';
6643
# If we're near the end, don't worry about it.
6644
next if $j == $fsize - 1;
6645
# If newline's coming up anyways, don't force another one.
6646
$c = substr $buffer, $j+1, 1;
6647
next if $c eq "\n";
6648
# Ok, it's a long line, we need to cut it.
6649
$spaceCol = length $newbuf if ! $spaceCol;
6650
substr($newbuf, $spaceCol, 0) = "=\n";
6651
$spaceCol += 2;
6652
$col = length($newbuf) - $spaceCol;
6653
$spaceCol = 0;
6654
}
6655
6656
if($isMail) {
6657
# Don't qp the subject.
6658
$newbuf =~ s/^.*/$subline/;
6659
}
6660
6661
$enc = "quoted-printable";
6662
$$res_type = $ctype;
6663
$$res_enc = $enc;
6664
$$res_data = $newbuf;
6665
return 1;
6666
}
6667
6668
# Almost all ascii, short lines, no problems.
6669
$enc = ($nacount ? "8bit" : "7bit");
6670
$$res_type = $ctype;
6671
$$res_enc = $enc;
6672
$$res_data = $buffer;
6673
return 1;
6674
} # encodeAttachment
6675
# Don't forget to turn lf into crlf before you send this on to smtp.
6676
6677
# Send mail to the smtp server.
6678
# sendMail(recipients, mailtext, attachments)
6679
# Everything passed by reference.
6680
sub sendMail($$$)
6681
{
6682
my ($tolist, $main, $atlist) = @_;
6683
length $outmailserver or
6684
$errorMsg = "No mail server specified - check your $home/.ebrc file", return 0;
6685
6686
my $proto = 'smtp';
6687
my $reply = $replyAddress[$whichMail];
6688
$altattach == 0 or $altattach == $#$atlist+1 or
6689
$errorMsg = 'either none or all of the attachments must be declared "alternative"', return 0;
6690
6691
# Read and/or refresh the address book.
6692
if(length $addressFile and -e $addressFile) {
6693
my $newtime = (stat($addressFile))[9];
6694
if($newtime > $adbooktime) {
6695
%adbook = ();
6696
$adbooktime = $newtime;
6697
my ($alias, $email);
6698
open FH, $addressFile or
6699
$errorMsg = "Cannot open address book $addressFile.", return 0;
6700
while(<FH>) {
6701
s/\n$//; # don't need nl
6702
next if /^\s*#/; # comment line
6703
next if /^\s*$/; # blank line
6704
($alias = $_) =~ s/:.*//;
6705
($email = $_) =~ s/^[^:]*:([^:]*).*/$1/;
6706
$adbook{$alias} = $email;
6707
}
6708
close FH;
6709
}
6710
}
6711
6712
# Resolve recipients against address book.
6713
foreach my $who (@$tolist) {
6714
next if $who =~ /@/;
6715
my $real = $adbook{$who};
6716
if(defined $real and length $real) {
6717
# Remember that $who is a by reference variable, being in the for loop.
6718
$who = $real;
6719
next;
6720
}
6721
length $addressFile or
6722
$errorMsg = "No address book specified - check your $home/.ebrc file", return 0;
6723
$errorMsg = "alias $who not found in your address book";
6724
return 0;
6725
}
6726
6727
# Verify attachments are readable.
6728
foreach my $f (@$atlist) {
6729
if($f =~ /^\d+$/) {
6730
my $cx = $f - 1;
6731
cxCompare($cx) or return 0;
6732
defined $factive[$cx] and $dol[$cx] or
6733
$errorMsg = "session $f is empty - cannot atach", return 0;
6734
} else {
6735
-r $f or
6736
$errorMsg = "cannot access attachment $f", return 0;
6737
}
6738
}
6739
6740
my $mustmime = $#$atlist + 1;
6741
my ($sendEnc, $sendType, $sendData);
6742
encodeAttachment($main, 1, \$sendEnc, \$sendType, \$sendData) or return 0;
6743
$mustmime = 1 if $sendEnc =~ /^q/;
6744
6745
# Boundary, for sending attachments.
6746
my $sendBound = rand;
6747
$sendBound =~ s/^0./nextpart-domail/;
6748
6749
# Looks good - let's get going.
6750
pop3connect($outmailserver, 25) or return 0;
6751
6752
normal: {
6753
serverGetLine() or last normal;
6754
while($serverLine =~ /^220-/) {
6755
serverGetLine() or last normal;
6756
}
6757
$serverLine =~ /^220 / or
6758
$errorMsg = "Unexpected prompt <$serverLine> at the start of the sendmail session", last normal;
6759
6760
serverPutLine "helo $smtplogin" or last normal;
6761
serverGetLine() or last normal;
6762
$serverLine =~ /^250 / or
6763
$errorMsg = "The mail server doesn't recognize $smtplogin", last normal;
6764
6765
serverPutLine "mail from: $reply" or last normal;
6766
serverGetLine() or last normal;
6767
$serverLine =~ /^250 / or
6768
$errorMsg = "mail server rejected $reply <$serverLine>", last normal;
6769
6770
my $reclist = ""; # list of recipients
6771
my $reccount = 0; # count recipients
6772
foreach my $f (@$tolist) {
6773
$f = "\"$f\"" if $f =~ /[^\w,.@=_-]/;
6774
$reclist .= ", " if $reccount;
6775
++$reccount;
6776
$reclist .= $f;
6777
serverPutLine "rcpt to: $f" or last normal;
6778
serverGetLine() or last normal;
6779
$serverLine =~ /^250 / or
6780
$errorMsg = "mail server rejected $f <$serverLine>", last normal;
6781
} # loop over recipients
6782
6783
serverPutLine "data" or last normal;
6784
serverGetLine() or last normal;
6785
$serverLine =~ /^354 / or
6786
$errorMsg = "The mail server is not ready to accept email data <$serverLine>", last normal;
6787
serverPutLine "To: $reclist$eol" .
6788
"From: $myname <$reply>$eol" .
6789
"Reply-To: $myname <$reply>$eol" .
6790
"Date: " . mailTimeString() . $eol .
6791
"Mime-Version: 1.0" or last normal;
6792
6793
# dot alone tells smtp we're done.
6794
# Make sure there isn't a dot line in the middle of the mail.
6795
$sendData =~ s/^\.$/ ./gm;
6796
# serverPutLine() routine already adds the last newline.
6797
substr($sendData, -1) = "" if substr($sendData, -1) eq "\n";
6798
# smtp requires crlf.
6799
$sendData =~ s/\n/\r\n/g;
6800
6801
if(! $mustmime) {
6802
serverPutLine "Content-Type: $sendType$eol" .
6803
"Content-Transfer-Encoding: $sendEnc" or last normal;
6804
} else {
6805
$sendData =~ s/^(.*\r\n)// or
6806
$errorMsg = "could not pull subject line out of sendData", last normal;
6807
my $subline = $1;
6808
serverPutLine $subline .
6809
"Content-Type: multipart/" .
6810
($altattach ? "alternative" : "mixed") .
6811
"; boundary=$sendBound$eol" .
6812
"Content-Transfer-Encoding: 7bit$eol" .
6813
$eol .
6814
"This message is in MIME format. Since your mail reader does not understand$eol" .
6815
"this format, some or all of this message may not be legible.$eol" .
6816
$eol .
6817
"--$sendBound$eol" .
6818
"Content-Type: $sendType$eol" .
6819
"Content-Transfer-Encoding: $sendEnc" or last normal;
6820
}
6821
serverPutLine $sendData or last normal;
6822
6823
if($mustmime) {
6824
foreach my $f (@$atlist) {
6825
encodeAttachment($f, 0, \$sendEnc, \$sendType, \$sendData) or last normal;
6826
serverPutLine "$eol--$sendBound$eol" .
6827
"Content-Type: $sendType" .
6828
# If the filename has a quote in it, forget it.
6829
# Also, suppress filename if this is an alternative presentation.
6830
# Also, suppress filename if you pulled it out of an edbrowse session.
6831
(($altattach or $f =~ /"/ or $f =~ /^\d+$/) ?
6832
"" : "; name=\"$f\"") . $eol .
6833
"Content-Transfer-Encoding: $sendEnc$eol" or last normal;
6834
6835
$sendData =~ s/^\.$/ ./gm;
6836
substr($sendData, -1) = "" if substr($sendData, -1) eq "\n";
6837
$sendData =~ s/\n/\r\n/g;
6838
serverPutLine $sendData or last normal;
6839
} # loop over attachments
6840
# Last boundary.
6841
serverPutLine "$eol--$sendBound--" or last normal;
6842
} # mime parts
6843
6844
serverPutLine "." or last normal;
6845
serverGetLine() or last normal;
6846
$serverLine =~ /message (accepted|received)/i or
6847
$serverLine =~ /^250/ or
6848
$errorMsg = "Could not send mail message <$serverLine>", last normal;
6849
serverClose($proto);
6850
return 1;
6851
} # normal processing
6852
6853
close SERVER_FH;
6854
return 0; # failed
6855
} # sendMail
6856
6857
# Send the current session as outgoing mail.
6858
sub sendMailCurrent()
6859
{
6860
dirBrowseCheck("send mail") or return 0;
6861
$fmode&$binmode and $errorMsg = "cannot mail a binary file - should this be an attachment?", return 0;
6862
$dol or $errorMsg = "cannot mail an empty file", return 0;
6863
$whichMail = $localMail;
6864
6865
# Gather recipients and attachments, until we reach subject:
6866
my @tolist = ();
6867
my @atlist = ();
6868
my ($ln, $t);
6869
my $subject = 0;
6870
for($ln=1; $ln<=$dol; ++$ln) {
6871
$t = fetchLine $ln, 0;
6872
$t =~ s/^reply[ -]to:* /to:/i;
6873
$t =~ s/^mailto:/to:/i;
6874
push(@tolist, $1), next if $t =~ /^to\s*:\s*(.*?)[ \t]*$/i;
6875
if($t =~ /^(attach|alt)\s*:\s*(.*?)[ \t]*$/i) {
6876
$altattach++ if lc($1) eq "alt";
6877
push(@atlist, $2);
6878
next;
6879
}
6880
$whichMail = $1, next if $t =~ /^account\s*:\s*(\d+)[ \t]*$/i;
6881
$subject = 1 if $t =~ /^subject\s*:/i;
6882
last;
6883
}
6884
$whichMail = $smMail if length $smMail;
6885
$subject or $errorMsg = "line $ln, should begin with to: attach: or subject:", return 0;
6886
$#tolist >= 0 or $errorMsg = "no recipients specified - place `To: emailAddress' at the top of your file", return 0;
6887
$whichMail <= $#inmailserver or $errorMsg = "account $whichMail is out of range", return 0;
6888
6889
my $tbuf = "";
6890
$tbuf .= fetchLine($_, 0) . "\n" foreach ($ln..$dol);
6891
$mailToSend = "buffer";
6892
return sendMail(\@tolist, \$tbuf, \@atlist);
6893
} # sendMailCurrent
6894
6895
6896
# runtime code starts here.
6897
# Think of this code as being inside main(){}
6898
6899
if($doslike) {
6900
# Buffered I/O messes me up when this runs on NT, over telnet.
6901
STDOUT->autoflush(1);
6902
# The shell doesn't expand wild cards, let's do it here.
6903
my @arglist = ();
6904
push @arglist, glob($_) foreach (@ARGV);
6905
@ARGV=@arglist;
6906
}
6907
6908
if($#ARGV >= 0 and $ARGV[0] eq "-v") {
6909
print "$version\n";
6910
exit 0;
6911
}
6912
6913
# debug option
6914
if($#ARGV >= 0 and $ARGV[0] =~ /^-d(\d*)$/) {
6915
$debug = (length $1 ? $1 : 4);
6916
shift @ARGV;
6917
}
6918
6919
# error exit option
6920
if($#ARGV >= 0 and $ARGV[0] eq '-e') {
6921
$errorExit = 1;
6922
shift @ARGV;
6923
}
6924
6925
# -m is a special flag; run as a mail client.
6926
if($#ARGV >= 0 and $ARGV[0] =~ /^-(u?)m(\d+)$/) {
6927
$ismc = 1; # running as a mail client
6928
my $unformat = length $1;
6929
my $account = $2;
6930
shift @ARGV;
6931
$#inmailserver >= 0 or
6932
dieq "there are no mail accounts in your .ebrc config file.";
6933
$account <= $#inmailserver or
6934
dieq "account designator $account is out of range.";
6935
$whichMail = $account;
6936
my @atfiles = ();
6937
my $mailBuf = "";
6938
6939
if($#ARGV == 0 and $ARGV[0] eq "-Zap") {
6940
$zapmail = 1;
6941
shift @ARGV;
6942
}
6943
6944
while($#ARGV>= 0) {
6945
my $arg = pop @ARGV;
6946
if($arg =~ s/^([-+])//) {
6947
++$altattach if $1 eq '-';
6948
open FH, $arg or
6949
dieq "cannot access attachment $arg.";
6950
close FH;
6951
unshift @atfiles, $arg;
6952
} else {
6953
$mailToSend = $arg;
6954
open FH, $mailToSend
6955
or dieq "Cannot access send file $mailToSend.";
6956
dieq "Send file $mailToSend has zero size." if -z FH;
6957
binmode FH, ':raw' if $doslike;
6958
my $fsize = (stat(FH))[7];
6959
my $rsize = sysread(FH, $mailBuf, $fsize);
6960
close FH;
6961
$rsize == $fsize or
6962
dieq "cannot read the contents of $mailToSend,$!";
6963
last;
6964
}
6965
} # loop looking for files to transmit
6966
6967
if(length $mailToSend or $#atfiles >= 0) {
6968
# Mail client is in send mode.
6969
length $mailToSend or
6970
dieq "all arguments are attachments - you must include a plain send file.";
6971
$#ARGV >= 0 or dieq "No recipients specified.";
6972
sendMail(\@ARGV, \$mailBuf, \@atfiles) or dieq $errorMsg;
6973
exit 0;
6974
} # send mail
6975
6976
# Move to the mail directory.
6977
length $mailDir or dieq "mailbox directory not specified in your .ebrc file.";
6978
chdir $mailDir or dieq "Cannot change directory to $mailDir.";
6979
6980
# Now fetch the mail and process it,
6981
# and ask the user what to do with it.
6982
# Begin with the pop3 login/password sequence.
6983
my $proto = "pop3";
6984
pop3connect($inmailserver[$whichMail], 110) or dieq $errorMsg;
6985
serverGetLine();
6986
$serverLine =~ /^\+OK /
6987
or dieq "Unexpected pop3 introduction <$serverLine>.";
6988
my $login = $pop3login[$whichMail];
6989
my $password = $pop3password[$whichMail];
6990
serverPutLine("user $login");
6991
serverGetLine();
6992
# perhaps we require a password?
6993
if($password) {
6994
serverPutLine("pass $password");
6995
serverGetLine();
6996
} # sending password
6997
$serverLine =~ /^\+OK/
6998
or dieq "Could not complete the pop3 login/password sequence <$serverLine>.";
6999
7000
# determine number of messages
7001
serverPutLine("stat");
7002
serverGetLine();
7003
$serverLine =~ /^\+OK /
7004
or dieq "Could not obtain status information on your mailbox <$serverLine>.";
7005
my $nmsgs = substr($serverLine, 4);
7006
$nmsgs =~ s/ .*//;
7007
7008
if(!$nmsgs) {
7009
print "No mail\n";
7010
serverClose($proto);
7011
exit 0;
7012
}
7013
7014
my $mailHuge = "Mail message consumes more than a million lines; you won't be able to use this client.";
7015
print "$nmsgs messages\n";
7016
if($zapmail) {
7017
$nmsgs = 300 if $nmsgs > 300;
7018
}
7019
7020
# Iterate over messages.
7021
foreach my $m (1..$nmsgs) {
7022
my ($filename, $j, $curpart, $rendered);
7023
# Is this mail automatically going somewhere else?
7024
my $redirect = "";
7025
my $delFlag = 0;
7026
7027
if($zapmail) {
7028
$delFlag = 1;
7029
} else {
7030
7031
# Clear out the editor before we read in the next message.
7032
foreach $j (0..$#factive) {
7033
cxReset $j, 1;
7034
}
7035
$context = 0; # probably not necessary
7036
$factive[0] = 1; # mail goes into session 0
7037
$#text = 1;
7038
$text[0] = "";
7039
$text[1] = "--------------------------------------------------------------------------------";
7040
7041
# retrieve the entire mth message from the server.
7042
serverPutLine("retr $m");
7043
my $exact_msg = ""; # an exact copy of the email
7044
# Throw first line away, it's from the pop3 server, not part of the mail.
7045
serverGetLine();
7046
$j = 1;
7047
serverGetLine();
7048
while($serverLine ne ".") {
7049
$exact_msg .= "$serverLine\n";
7050
lineLimit 1 and dieq $mailHuge;
7051
push @text, $serverLine;
7052
++$j;
7053
$map .= sprintf($lnformat, $j);
7054
serverGetLine();
7055
}
7056
$dot = $dol = $j-1;
7057
7058
if(not $unformat) {
7059
# Browse the mail message for display.
7060
$btags[0] = $btags = [];
7061
$$btags[0] = {tag => "special", fw => {} };
7062
$badHtml = 1;
7063
$mailSubject = $mailFrom = $mailReply = $mailDate = "";
7064
renderMail(\$rendered) and pushRenderedText(\$rendered) or
7065
dieq $errorMsg;
7066
$rendered = undef; # don't need it any more
7067
7068
# Break the lines in the buffer.
7069
$fmode &= ~$browsemode; # so I can run the next command
7070
evaluate(",bl");
7071
$errorMsg = "";
7072
$dot = $dol;
7073
$fmode |= $browsemode;
7074
7075
# Let user know about attachments.
7076
my $unat = 0; # unnamed attachments
7077
my $exat = 0; # attachment already exists
7078
if($nat) {
7079
print "$nat attachments.\n";
7080
$j = 0;
7081
foreach $curPart (@mimeParts) {
7082
next unless $$curPart{isattach};
7083
++$j;
7084
$filename = $$curPart{filename};
7085
++$unat, next unless length $filename;
7086
print "$j = $filename";
7087
if(-e $filename) {
7088
print " exists";
7089
$exat = 1;
7090
}
7091
print "\n";
7092
}
7093
}
7094
7095
# Paste on the html segments.
7096
foreach $j (1..$#factive) {
7097
next unless $factive[$j];
7098
next unless $dol[$j];
7099
$map .= sprintf($lnformat, 0) if $dol;
7100
if($dol > 4) {
7101
$map .= sprintf($lnformat, 1);
7102
$map .= sprintf($lnformat, 0);
7103
}
7104
$map .= substr($map[$j], $lnwidth);
7105
$dot = $dol = length($map)/$lnwidth - 1;
7106
}
7107
foreach my $t (@text) {
7108
removeHiddenNumbers \$t;
7109
}
7110
7111
# See if the mail is redirected.
7112
if(length $mailReply and $#fromSource >= 0) {
7113
my $lowReply = lc $mailReply;
7114
foreach my $j (0..$#fromSource) {
7115
next unless index($lowReply, $fromSource[$j]) >= 0;
7116
$redirect = $fromDest[$j];
7117
last;
7118
}
7119
}
7120
7121
# I'm not going to redirect mail if there are unamed or existing attachments.
7122
$redirect = "" if $redirect ne "x" and $unat + $exat;
7123
} # formatting the mail message
7124
7125
my $dispLine = 1;
7126
if(length $redirect) {
7127
$delFlag = 1;
7128
# Replace % date/time fields.
7129
if($redirect =~ /%[ymdhns]{2,}/) {
7130
my ($ss, $nn, $hh, $dd, $mm, $yy) = localtime time;
7131
$mm++;
7132
$yy += 1900;
7133
$redirect =~ s/%yyyy/sprintf "%4d", $yy/ge;
7134
$redirect =~ s/%yy/sprintf "%02d", $yy%100/ge;
7135
$redirect =~ s/%mm/sprintf "%02d", $mm/ge;
7136
$redirect =~ s/%dd/sprintf "%02d", $dd/ge;
7137
$redirect =~ s/%hh/sprintf "%02d", $hh/ge;
7138
$redirect =~ s/%nn/sprintf "%02d", $nn/ge;
7139
$redirect =~ s/%ss/sprintf "%02d", $ss/ge;
7140
}
7141
print "$mailReply > $redirect\n";
7142
}
7143
7144
# display the next page of mail and get an input character.
7145
dispInput: {
7146
if(! $delFlag) {
7147
print("skipped\n"), $delFlag = 1, last if ! $unformat and length $mailSubject and defined $junkSubjects{$mailSubject};
7148
foreach $j (keys %junkSubjects) {
7149
next unless $j =~ /^`/;
7150
my $trash = $j;
7151
$trash =~ s/^`//;
7152
next unless index($exact_msg, $trash) >= 0;
7153
print("trash\n"), $delFlag = 1, last dispInput;
7154
}
7155
if($dispLine <= $dol) {
7156
foreach $j (1..20) {
7157
last if $dispLine > $dol;
7158
my $line = fetchLine $dispLine, 0;
7159
# Don't print date and return address, but they will be recorded,
7160
# if you save the file.
7161
next if $line =~ /^Mail sent /;
7162
next if $line =~ /^Reply to /;
7163
print "$line\n";
7164
} continue { ++$dispLine; }
7165
} # display next page
7166
} # not being deleted
7167
7168
getkey: {
7169
my $key;
7170
if($delFlag) {
7171
last if $redirect eq "x";
7172
$key = 'w';
7173
} else {
7174
# Interactive prompt depends on whether there is more text or not.
7175
STDOUT->autoflush(1);
7176
print ($dispLine > $dol ? "? " : "* ");
7177
STDOUT->autoflush(0);
7178
7179
$key = userChar("qx? nwkuJdA");
7180
print "\b\b";
7181
7182
exit 0 if $key eq 'x';
7183
print("quit\n"), serverClose($proto), exit 0 if $key eq 'q';
7184
print("next\n"), last dispInput if $key eq 'n';
7185
print("delete\n"), $delFlag = 1, last dispInput if $key eq 'd';
7186
7187
if($key eq ' ') {
7188
print "End of message\n" if $dispLine > $dol;
7189
redo dispInput;
7190
}
7191
7192
if($key eq '?') {
7193
print "?\tprint this help message.
7194
q\tquit this program.
7195
x\texit without changing anything on the mail server.
7196
space\tread more of this mail message.
7197
n\tmove on to the next mail message.
7198
A\tadd the sender to your address book.
7199
d\tdelete this message.
7200
J\tjunk this subject, and delete any mail with this subject.
7201
w\twrite this message to a file and delete it.
7202
k\tkeep this message in a file, but don't delete it.
7203
u\twrite this message unformatted to a file, and delete it.\n";
7204
redo;
7205
}
7206
7207
if($key eq 'J') {
7208
print "No subject to junk\n", redo if $mailSubject eq "";
7209
print "No junkfile specified in your .ebrc file\n", redo unless length $junkFile;
7210
print "junk\n";
7211
markSubject($mailSubject);
7212
$delFlag = 1;
7213
last dispInput;
7214
} # J
7215
7216
if($key eq 'A') {
7217
print "No addressbook specified in your .ebrc file\n", redo unless length $addressFile;
7218
print "Cannot establish sender's name and/or email address.", redo unless length $mailFrom and length $mailReply;
7219
open FH, ">>$addressFile"
7220
or dieq "Cannot append to $addressFile.";
7221
$_ = lc $mailFrom;
7222
s/\s/./g;
7223
print "$_:$mailReply\n";
7224
print FH "$_:$mailReply\n";
7225
close FH;
7226
redo;
7227
} # A
7228
} # delFlag or not
7229
7230
# At this point we're saving the mail somewhere.
7231
$delFlag = 1 if $key ne 'k';
7232
7233
if(length $redirect) {
7234
$filename = $redirect;
7235
} else {
7236
$filename = getFileName(undef, 0);
7237
}
7238
if($filename ne "x") {
7239
my $append = (-e $filename);
7240
open FH, ">>$filename"
7241
or dieq "Cannot create mail file $filename."; # should not happen
7242
my $fsize = 0;
7243
if($key eq 'u'or $unformat) {
7244
print FH $exact_msg
7245
or dieq "Cannot write to mail file $filename.";
7246
$fsize = length $exact_msg;
7247
} else {
7248
foreach $j (1..$dol) {
7249
my $line = fetchLine $j, 0;
7250
print FH "$line\n"
7251
or dieq "Cannot write to mail file $filename.";
7252
$fsize += length($line) + 1;
7253
}
7254
}
7255
close FH;
7256
print "mail saved, $fsize bytes";
7257
print " appended" if $append;
7258
print "\n";
7259
}
7260
7261
if($key ne 'u' and $redirect ne 'x') {
7262
# Ask the user about any attachments.
7263
$j = 0;
7264
foreach $curPart (@mimeParts) {
7265
next unless $$curPart{isattach};
7266
++$j;
7267
$filename = $$curPart{filename};
7268
if(length $redirect) {
7269
print "attach $filename\n";
7270
} else {
7271
print "Attachment $j ";
7272
$filename = getFileName($filename, 1);
7273
next if $filename eq "x";
7274
}
7275
open FH, ">$filename"
7276
or dieq "Cannot create attachment file $filename.";
7277
binmode FH, ':raw' if $doslike;
7278
print FH $$curPart{data}
7279
or dieq "Cannot write to attachment file $filename.";
7280
close FH;
7281
} # loop over attachments
7282
} # key other than 'u'
7283
7284
} # input key
7285
} # display and input
7286
} # interactive or zap
7287
7288
if($delFlag) { # Delete the message.
7289
# Remember, it isn't really gone until you quit the session.
7290
# So if you didn't want to delete, type x to exit abruptly,
7291
# then fetch your mail again.
7292
serverPutLine("dele $m");
7293
serverGetLine();
7294
$serverLine =~ /^\+OK/
7295
or dieq "Unable to delete message <$serverLine>.";
7296
} # Del
7297
7298
} # loop over messages
7299
7300
print "$nmsgs\n" if $zapmail;
7301
7302
serverClose($proto); # that's all folks!
7303
exit 0;
7304
} # end mail client
7305
7306
# Initial set of commands.
7307
if($commandList{init}) {
7308
evaluateSequence($commandList{init}, $commandCheck{init});
7309
}
7310
7311
# Process the command line arguments.
7312
foreach my $cx (0..$#ARGV) {
7313
my $file = $ARGV[$cx];
7314
cxSwitch($cx, 0) if $cx;
7315
$changeFname = "";
7316
my $rc = readFile($file, "");
7317
print "$filesize\n";
7318
$rc or print $errorMsg,"\n";
7319
$fname = $file;
7320
$fname = $changeFname if length $changeFname;
7321
$fmode &= ~($changemode|$firstopmode);
7322
if($rc and $filesize and is_url($fname)) {
7323
# Go ahead and browse it.
7324
$inglob = $intFlag = 0;
7325
$filesize = -1;
7326
$rc = evaluate("b");
7327
print "$filesize\n" if $filesize >= 0;
7328
$rc or print "$errorMsg\n";
7329
} # open of url
7330
} # loop over args on the command line
7331
cxSwitch(0, 0) if $context;
7332
print "edbrowse ready\n" if ! length $fname;
7333
7334
# get user commands.
7335
while(1) {
7336
my $line = readLine();
7337
my $saveLine = $line;
7338
$inglob = 0;
7339
$intFlag = 0;
7340
$filesize = -1;
7341
my $rc = evaluate($line);
7342
print "$filesize\n" if $filesize >= 0;
7343
if(!$rc) {
7344
print ((($helpall or $cmd =~ /[$showerror_cmd]/o) ? $errorMsg : "?"), "\n");
7345
exit 1 if $errorExit;
7346
}
7347
$linePending = $saveLine;
7348
if($ubackup) {
7349
$lastdot = $savedot, $lastdol = $savedol;
7350
$lastmap = $savemap, $lastlabels = $savelabels;
7351
$ubackup = 0;
7352
}
7353
} # infinite loop
7354
7355
#*********************************************************************
7356
# The following code is written and maintained by Chris Brannon,
7357
# cbrannon@wilnet1.com
7358
# It manages secure http and ftp connections.
7359
#*********************************************************************
7360
7361
sub do_ssl($$$$)
7362
{
7363
# Do the SSL thing. This takes four arguments: server, port, message,
7364
# and buffer reference.
7365
# <message> is a scalar containing http headers. <buffer reference> is
7366
# a reference to a scalar. We tack each chunk of received data onto that
7367
# scalar. Thusly, we don't have to return a variable containing twenty
7368
# MB of data.
7369
# I borrow heavily from Karl's plain http connection code.
7370
unless(eval { require Net::SSLeay }) {
7371
$errorMsg = "you must have the Net::SSLeay module and OpenSSL toolkit to speak https", return 0;
7372
}
7373
# Should I error-check these values? I don't know. Probably.
7374
my $server = shift;
7375
my $port = shift;
7376
my $message = shift;
7377
my $bufref = shift;
7378
my $iaddr = inet_aton($server) or
7379
$errorMsg = "Cannot identify $server on the network", return 0;
7380
my $paddr = sockaddr_in($port, $iaddr);
7381
my $proto = getprotobyname('tcp');
7382
socket(FH, PF_INET, SOCK_STREAM, $proto) or
7383
$errorMsg = "cannot allocate a socket", return 0;
7384
connect(FH, $paddr) or
7385
$errorMsg = "cannot connect to $server on $port: $!", return 0;
7386
Net::SSLeay::load_error_strings();
7387
Net::SSLeay::SSLeay_add_ssl_algorithms();
7388
Net::SSLeay::randomize();
7389
$ctx = Net::SSLeay::CTX_new();
7390
Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL);
7391
if($ssl_verify) {
7392
Net::SSLeay::CTX_load_verify_locations($ctx, $ebcerts, '') or
7393
$errorMsg = "Error opening certificate file $ebcerts: $!", return 0;
7394
Net::SSLeay::CTX_set_verify($ctx, &Net::SSLeay::VERIFY_PEER, 0);
7395
}
7396
# Should the user be warned somehow when SSL certificate verification has
7397
# been turned off? Accepting unverifiable certificates can be a security
7398
# risk. But some servers, like https://listman.redhat.com can't be verified
7399
# with my certificate bundle. So I make verification the default, but optional.
7400
$ssl = Net::SSLeay::new($ctx);
7401
Net::SSLeay::set_fd($ssl, fileno(FH)) or
7402
$errorMsg = Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error()), return 0;
7403
if(Net::SSLeay::connect($ssl) == -1) {
7404
$errorMsg = Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
7405
return 0;
7406
}
7407
Net::SSLeay::ssl_write_all($ssl, $message) or
7408
$errorMsg = &Net::SSLeay::ERR_error_string(&Net::SSLeay::ERR_get_error()), return 0;
7409
my ($chunk, $filesize, $rsize, $last_fk, $fk);
7410
$fk = $last_fk = 0;
7411
STDOUT->autoflush(1) if ! $doslike;
7412
while($chunk = Net::SSLeay::ssl_read_all($ssl, 100000)) {
7413
$$bufref .= $chunk; # how cute!
7414
$rsize = length($chunk); # Is this computationally expensive??
7415
$filesize += $rsize;
7416
last if $rsize == 0;
7417
$fk = int($filesize / 100000);
7418
if($fk > $last_fk) {
7419
print ".";
7420
$last_fk = $fk;
7421
}
7422
last if($filesize >= $maxfile);
7423
}
7424
close(FH);
7425
print "\n" if $last_fk > $fk;
7426
STDOUT->autoflush(0) if ! $doslike;
7427
$filesize <= $maxfile or
7428
$errorMsg = "file is too large, limit 40MB", return 0;
7429
defined $rsize or
7430
$errorMsg = "error reading data from the socket", return 0;
7431
# There's no way to distinguish between a read error and reading a zero
7432
# length file. I guess that's ok.
7433
if(defined($filesize)) {
7434
return $filesize;
7435
} else {
7436
return 0;
7437
}
7438
} # do_ssl
7439
7440
sub ftp_connect($$$$)
7441
{
7442
my($host, $port, $path, $bufref) = @_;
7443
my $proto = 'ftp';
7444
my ($tempbuf, @disposeOf);
7445
my $filesize = 0;
7446
my $login = "anonymous";
7447
my $password = 'some-user@edbrowse.net';
7448
my $dataOpen = (
7449
$passive ? \&pasvOpen : \&ftpListen);
7450
if($host =~ s/^([^:@]*):([^:@]*)@//) {
7451
$login = $1, $password = $2;
7452
}
7453
# Do an ftp connect, prompting for username & password.
7454
my $iaddr = inet_aton($host) or
7455
$errorMsg = "cannot identify $host on the network", return 0;
7456
my $paddr = sockaddr_in($port, $iaddr);
7457
socket(SERVER_FH, PF_INET, SOCK_STREAM, getprotobyname('tcp')) or
7458
$errorMsg = "cannot allocate a socket", return 0;
7459
connect(SERVER_FH, $paddr) or
7460
$errorMsg = "cannot connect to $host", return 0;
7461
SERVER_FH->autoflush(1);
7462
STDOUT->autoflush(1) if !$doslike;
7463
serverGetLine or serverClose($proto), return 0;
7464
serverClose($proto), return 0 if ftpError($serverLine, 220, "server sent \"$serverLine\" while attempting login");
7465
serverPutLine "user $login";
7466
do {
7467
serverGetLine or serverClose($proto), return 0;
7468
}
7469
while($serverLine =~ /^220/);
7470
serverClose($proto), return 0 if ftpError($serverLine, 331, "invalid username: server sent $serverLine");
7471
serverPutLine "pass $password";
7472
serverGetLine or serverClose($proto), return 0;
7473
serverClose($proto), return 0 if ftpError($serverLine, 230, "bad password: server sent $serverLine");
7474
my $wmsg = ""; # welcome message
7475
if($serverLine =~ s/^\s*230\s*?-\s*//) {
7476
# We got a welcome message.
7477
$wmsg = "$serverLine\n";
7478
while(serverGetLine) {
7479
last if $serverLine =~ /^\s*230\s*?[^-]/;
7480
$serverLine =~ s/^\s*230\s*?-\s*//;
7481
$wmsg .= "$serverLine\n";
7482
}
7483
}
7484
$wmsg = "" unless $path eq "/"; # trash the welcome message, we're going somewhere else
7485
serverPutLine "CWD $path";
7486
serverGetLine or serverClose($proto), return 0;
7487
if($serverLine =~ /^\s*250\s*/) {
7488
if($serverLine =~ s/^\s*250\s*?-\s*//) {
7489
# Its a directory-specific greeting.
7490
$wmsg = "$serverLine\n";
7491
while(serverGetLine) {
7492
last if $serverLine =~ /^\s*250\s*?[^-]/;
7493
$serverLine =~ s/^\s*250\s*?-\s*//;
7494
$wmsg .= "$serverLine\n";
7495
}
7496
}
7497
serverPutLine "type a";
7498
serverGetLine or serverClose($proto), return 0;
7499
serverClose($proto), return 0 if ftpError($serverLine, 200, "ASCII transfers not supported by server: received \"$serverLine\"");
7500
&$dataOpen or
7501
serverClose($proto), return 0;
7502
serverPutLine "list";
7503
serverGetLine or serverClose($proto), return 0;
7504
serverClose($proto), return 0 if ftpError($serverLine, "150", "error retrieving directory listing");
7505
$tempbuf = "";
7506
ftpRead(\$tempbuf) or
7507
serverClose($proto), return 0;
7508
ParseList: {
7509
serverPutLine "syst";
7510
serverGetLine or serverClose($proto), return 0;
7511
if($serverLine =~ /unix/i) {
7512
# Good. Let's try to htmlize this file listing.
7513
my $base_filename = "ftp://$host";
7514
$base_filename .= ":$port" if $port != 21;
7515
$base_filename .= $path;
7516
$base_filename .= '/' if $base_filename !~ m,/$,;
7517
# Yah, I know. That looks disgusting.
7518
textUnmeta(\$wmsg);
7519
$$bufref = "http/1.0 200 ok$eol$eol<html><head><title>Directory Listing</title>\n</head>\n<body>\n$wmsg<ul>\n";
7520
my @lines = split("$eol", $tempbuf);
7521
shift(@lines); # Ditch the "total: xxx" line from Unix ls
7522
foreach $line (@lines) {
7523
# Extract the filename and length from ls -l format
7524
my @listItems = split /\s+/, $line;
7525
my $mode = $listItems[0];
7526
my $extracted = $listItems[$#listItems];
7527
my $extlen = $listItems[$#listItems-4];
7528
$extlen = "/" if $mode =~ /^d/;
7529
$$bufref .= "<li><a href=\"$base_filename$extracted\">$extracted</a> $extlen\n";
7530
}
7531
$$bufref .= "</ul>\n</body>\n</html>\n";
7532
$$bufref =~ s/<ul>\n<\/ul>/This ftp directory is empty./;
7533
$filesize = length($$bufref);
7534
} else {
7535
$$bufref = $tempbuf; # Oh well...
7536
}
7537
serverPutLine "quit";
7538
@disposeOf = <SERVER_FH>;
7539
close SERVER_FH;
7540
return 0 if !$filesize;
7541
return $filesize;
7542
} # ParseList
7543
} else {
7544
# Try to retr. If unable, the path was bogus.
7545
serverPutLine "type i";
7546
serverGetLine or serverClose($proto), return 0;
7547
serverClose($proto), return 0 if ftpError($serverLine, 200, "binary transfers unsupported by server: received \"$serverLine\"");
7548
&$dataOpen or
7549
serverClose($proto), return 0;
7550
serverPutLine "retr $path";
7551
serverGetLine or serverClose($proto), return 0;
7552
serverClose($proto), return 0 if ftpError($serverLine, "150",
7553
"the path you specified in this URL is neither a filename nor a directory");
7554
# Let's read our data.
7555
$filesize = ftpRead($bufref);
7556
serverClose($proto);
7557
# The problem is, the ftp server will get an extraneous abor command when
7558
# we close connection. I only want these sent after an error condition, to
7559
# abort a transfer.
7560
return 0 if !$filesize;
7561
return $filesize;
7562
}
7563
} # ftp_connect
7564
7565
sub ftpRead($)
7566
{
7567
# I don't like the fact that this subroutine returns 0 on error. Seems wrong.
7568
my $bufref = shift;
7569
my $rsize = 0;
7570
my $filesize = 0;
7571
my $last_fk = 0;
7572
my $chunk;
7573
my $proto = 'ftp';
7574
if(!$passive) {
7575
my $check = '';
7576
vec($check, fileno(FLFH), 1) = 1;
7577
select($check, undef, undef, 10) or
7578
$errorMsg = "ftp data connection timed out", $filesize = 0, goto Cleanup;
7579
socket(FDFH, PF_INET, SOCK_STREAM, getprotobyname('TCP')) or
7580
$errorMsg = "unable to allocate a socket", $filesize = 0, goto Cleanup;
7581
accept(FDFH, FLFH);
7582
shutdown(FDFH, 1);
7583
}
7584
while(defined($rsize = sysread(FDFH, $chunk, 100000))) {
7585
print "sockread $rsize\n" if $debug >= 5;
7586
$$bufref .= $chunk;
7587
$filesize += $rsize;
7588
last if $rsize == 0;
7589
my $fk = int($filesize / 100000);
7590
if($fk > $last_fk) {
7591
print ".";
7592
$last_fk = $fk;
7593
}
7594
last if $filesize >= $maxfile;
7595
}
7596
my $line;
7597
serverGetLine or return 0;
7598
close FDFH;
7599
close FLFH;
7600
# ignore it; it should read 226 transfer complete
7601
print "\n" if $last_fk;
7602
defined($rsize) or
7603
$errorMsg = "error reading data from the socket", $filesize = 0, goto Cleanup;
7604
$filesize <= $maxfile or
7605
$errorMsg = "file to large: 4-1M limit", $filesize = 0, goto Cleanup;
7606
$filesize > 0 or
7607
$errorMsg = "empty file", $filesize = 0, goto Cleanup;
7608
Cleanup: {
7609
close FDFH if defined FDFH;
7610
close FLFH if defined FLFH;
7611
return $filesize;
7612
}
7613
} # ftpRead
7614
7615
sub ftpError($$$)
7616
{
7617
# This subroutine matches an ftp response against an status code. The code can
7618
# be specified as a regexp. So, 25[0-9] as the status code will let us match
7619
# any of the 25X status codes.
7620
# It returns 1 on error. This subroutine used to do cleanup, but
7621
# I'm leaving this job to the main ftp subroutine.
7622
my ($input, $statcode, $errmsg) = @_;
7623
$errorMsg = $errmsg, return 1 if($input !~ /^\s*$statcode/);
7624
return 0;
7625
} # ftpError
7626
7627
sub pasvOpen()
7628
{
7629
my ($line, $packed_ftpaddr, $ipaddr, $port);
7630
serverPutLine "pasv";
7631
serverGetLine or return 0;
7632
return 0 if ftpError($serverLine, '227', "server doesn't support passive mode: received \"$serverLine\"");
7633
if($serverLine =~ /([0-9]+,[0-9]+,[0-9]+,[0-9]+,[0-9]+,[0-9]+)/) {
7634
$packed_ftpaddr = pack("C6", split(',', $1));
7635
} else {
7636
$errorMsg = "cannot make ftp data connection: server sent \"$serverLine\"";
7637
return 0;
7638
}
7639
$ipaddr = substr($packed_ftpaddr, 0, 4);
7640
$port = unpack("n", substr($packed_ftpaddr, 4, 2));
7641
# The address for ftp data connections is written this way:
7642
# 127,0,0,1,100,100
7643
# We turn those decimal notations into a packed string of unsigned chars..
7644
# The first four characters are the IP address in network byte order. They
7645
# are fed directly to sockaddr_in. The last two are unpacked as an
7646
# unsigned short in NBO. The new decimal representation is fed to sockaddr_in.
7647
my $saddr = sockaddr_in($port, $ipaddr);
7648
socket(FDFH, PF_INET, SOCK_STREAM, getprotobyname('tcp')) or
7649
$errorMsg = "cannot allocate a socket", return 0;
7650
connect(FDFH, $saddr) or
7651
$errorMsg = "cannot open ftp data connection", return 0;
7652
shutdown(FDFH, 1); # Hmm. My server hangs if this doesn't happen...
7653
return 1;
7654
} # pasvOpen
7655
7656
sub ftpListen {
7657
my $ctladdr = (sockaddr_in(getsockname(SERVER_FH)))[1];
7658
$errorMsg = "unable to obtain address of control connection; cannot initiate data connection",
7659
return 0 if !$ctladdr;
7660
my $port = int(rand(64510) + 1025);
7661
socket(FLFH, PF_INET, SOCK_STREAM, getprotobyname('tcp')) or
7662
$errorMsg = "unable to allocate a socket", return 0;
7663
my $saddr = sockaddr_in($port, $ctladdr);
7664
bind(FLFH, $saddr) or
7665
$errorMsg = "unable to bind socket: port $port $!", return 0;
7666
listen(FLFH, 1) or
7667
$errorMsg = "unable to listen on ftp data socket", return 0;
7668
serverPutLine sprintf("port %d,%d,%d,%d,%d,%d", unpack('C4', $ctladdr), $port >> 8, $port & 255);
7669
serverGetLine or return 0;
7670
return 0 if ftpError($serverLine, '200', "ftp server does not support port command, received \"$serverLine\"");
7671
shutdown(FLFH, 1);
7672
return 1;
7673
} # ftpListen
7674
7675
7676
7677
# Cookie support
7678
sub setCookies($$)
7679
{
7680
# We only support Netscape-style cookies presently. The newer style will
7681
# be supported eventually. It offers some functionality that Netscape's
7682
# doesn't.
7683
my $cookie = shift;
7684
print "incoming cookie: $cookie\n" if $debug >= 4;
7685
$cookie =~ s/^Set-Cookie:\s+//i;
7686
stripWhite \$cookie;
7687
return unless length $cookie;
7688
my $url_desc = shift;
7689
my @cook_array = split(';', $cookie);
7690
# We should have the cookie into its component parts.
7691
my($name, $value, $path, $domain, $expires, $secure);
7692
($name, $value) = split('=', shift(@cook_array), 2);
7693
$value = "" unless defined $value;
7694
my $crumb;
7695
while($crumb = shift(@cook_array)) {
7696
stripWhite \$crumb;
7697
$crumb = "secure=" if $crumb =~ /^secure$/i;
7698
if($crumb =~ s/^domain=//i) {
7699
# Do some work on $crumb to protect us from general maliciousness/idiocy.
7700
my $workingserver = $$url_desc{SERVER};
7701
next unless $$url_desc{SERVER} =~ /\Q$crumb\E$/i;
7702
my $l = length $crumb;
7703
next if length($workingserver) > $l and substr($crumb, 0, 1) ne '.' and substr($workingserver, -$l-1, 1) ne '.';
7704
# We simply won't use a bogus domain attribute. We ignore it, and the domain
7705
# eventually is set to the default.
7706
# In other words, we don't want somebody sending us a cookie for all of .com.
7707
my $numfields = $crumb =~ y/././;
7708
++$numfields unless substr($crumb, 0, 1) eq '.';
7709
if($crumb =~ /\.(net|com|gov|edu|mil|org|int|tv|bus)$/i) {
7710
# One nasty regexp, oh well. Domain attributes from these domains may
7711
# have a minimum of two fields.
7712
next if $numfields < 2;
7713
} else {
7714
# Everyone else needs three fields.
7715
next if $numfields < 3;
7716
}
7717
$domain = $crumb;
7718
} elsif($crumb =~ s/^path=//i) {
7719
$path = $crumb;
7720
} elsif($crumb =~ s/^expires=?\s*//i) {
7721
# Squeeze a time_t out of the date string, hopefully! If not, then "-1"
7722
# is used as the date, so the cookie will expire on quit.
7723
$expires = cookieDate($crumb);
7724
} elsif($crumb =~ s/^max-age=?\s*//i) {
7725
if($crumb =~ /^\d+$/ and not defined $expires) {
7726
$expires = time() + $crumb;
7727
}
7728
} elsif($crumb =~ s/^secure=//i) {
7729
# SSL-only cookie.
7730
$secure = 1;
7731
} else {
7732
print STDERR "Error processing cookie with element $crumb\n"; # debugging statement
7733
}
7734
}
7735
$domain = $$url_desc{SERVER} if !defined $domain;
7736
# Here's what it should be, according to the standard.
7737
# $path = $$url_desc{PATH} if !defined $path;
7738
# Here's what some sites require, such as http://tdzk.net
7739
# This is apparently what Explorer does.
7740
# Oh well, who the hell needs standards;
7741
# when you're a monopoly you set the standards.
7742
$path = "/" if !defined $path;
7743
$expires = -1 if !defined $expires;
7744
$secure = 0 if !defined $secure; # For secure cookies, it will have been set to 1
7745
# Put the cookie into the master cookie jar.
7746
print "into jar: $domain $path $expires $name $value\n" if $debug >= 4;
7747
$cookies{$domain}{$path}{$name} =
7748
{value => $value, expires => $expires, secure => $secure};
7749
# If a server sends two cookies of the same path and name, with different values,
7750
# the former will be quashed by the latter. This is proper behavior.
7751
if($expires != -1) { # Persistent cookie.
7752
my $chmodFlag = 0;
7753
$chmodFlag = 1 unless -f $ebcooks;
7754
# Now, append to the cookie file.
7755
# I learned the format for Netscape's cookie file from lynx's source. Thank you, lynx team.
7756
if(!open(COOKFILE, ">>$ebcooks")) {
7757
warn "unable to open cookie jar for append: $!";
7758
} else {
7759
chmod 0600, $ebcooks if $chmodFlag;
7760
print COOKFILE join("\t", $domain, 'FALSE', $path,
7761
$secure ? 'TRUE' : 'FALSE', $expires, $name, $value) . "\n";
7762
# A note. Lynx defines a field, "what". I don't know what its used
7763
# for. But all the Netscape cookie files I've seen have it set to "FALSE".
7764
# so will we.
7765
# Maybe its proprietary to Netscape's browser.
7766
close COOKFILE;
7767
}
7768
}
7769
} # setCookies
7770
7771
sub fetchCookies($)
7772
{
7773
my $url_desc = shift;
7774
my $cur_scheme = $$url_desc{SCHEME};
7775
my $cur_domain = $$url_desc{SERVER};
7776
my $cur_path = $$url_desc{PATH};
7777
my ($domainm, $pathm, $cookiem); # The 'm' at the end stands for 'match'
7778
my @sendable = (); # Sendable cookie strings.
7779
foreach $domainm (keys(%cookies)) {
7780
next unless $cur_domain =~ /\Q$domainm\E$/i;
7781
my $l = length $domainm;
7782
next if length($cur_domain) > $l and substr($domainm, 0, 1) ne '.' and substr($cur_domain, -$l-1, 1) ne '.';
7783
foreach $pathm (keys(%{$cookies{$domainm}})) {
7784
next unless $cur_path =~ /^\Q$pathm\E/;
7785
foreach $cookiem (keys(%{$cookies{$domainm}{$pathm}})) {
7786
my $deref = $cookies{$domainm}{$pathm}{$cookiem};
7787
# $deref is a simple hash reference, containing the description of one cookie.
7788
# We can do the rest of our matching painlessly, without dereferencing
7789
# the whole nasty data structure every time.
7790
next if $$deref{secure} and ($cur_scheme !~ /https/);
7791
my $j = join('=', $cookiem, $$deref{value});
7792
$j =~ s/=$//;
7793
push @sendable, $j;
7794
print "outgoing cookie: $domainm $pathm $j\n" if $debug >= 4;
7795
}
7796
}
7797
}
7798
return "" if $#sendable < 0; # no cookies
7799
my $outgoing = 'Cookie: ' . join("; ", @sendable);
7800
# Lynx prepends a cookie2: directive.
7801
# I don't know what it means or what it's for. Here it is.
7802
return "Cookie2: \$Version=1$eol$outgoing$eol";
7803
} # fetchCookies
7804
7805
sub cookieDate($)
7806
{
7807
# This might become a general http date decoder, if we ever find
7808
# places where dates are useful.
7809
my $datestring = shift;
7810
stripWhite \$datestring;
7811
if($datestring =~ /^[a-z]{3,9},\s+(\d\d)[- ]([a-z]{3})[- ](\d\d(?:\d\d)?)\s+(\d\d):(\d\d):(\d\d)\s+GMT/i) {
7812
my ($day, $mon, $year, $hour, $min, $sec) = ($1, $2, $3, $4, $5, $6);
7813
if(($year < 100) and ($year > 0)) {
7814
# two digit.
7815
if($year >= 70) {
7816
$year += 1900;
7817
} else { $year += 2000; }
7818
}
7819
$mon = $monhash{lc($mon)} - 1;
7820
# We should probably range-check all the fields,
7821
# but year is definitely necessary.
7822
$year = 2035 if $year > 2035;
7823
$year = 1970 if $year < 1970;
7824
my $time = timegm($sec, $min, $hour, $day, $mon, $year);
7825
return $time;
7826
} else {
7827
return -1;
7828
}
7829
} # cookyDate
7830
7831
sub fillJar()
7832
{
7833
# Initialize the cookie jar.
7834
my $writeFlag = 0; # Write revised cookie file?
7835
open(COOKFILE, "+<$ebcooks") or return;
7836
my $inline;
7837
my $nowtime = time;
7838
while($inline = <COOKFILE>) {
7839
chomp $inline;
7840
my ($domain, $what, $path, $secure, $expires, $name, $value) = split("\t", $inline);
7841
$writeFlag = 1 if exists $cookies{$domain}{$path}{$name};
7842
if($expires > $nowtime) {
7843
$cookies{$domain}{$path}{$name} =
7844
{value => $value, secure => $secure eq "TRUE" ? 1 : 0, expires => $expires}
7845
} else {
7846
$writeFlag = 1;
7847
} # cookies expired.
7848
} # loop reading
7849
if($writeFlag) {
7850
seek COOKFILE, 0, 0;
7851
truncate COOKFILE, 0;
7852
my ($odomain, $opath, $ocook); # o for out
7853
foreach $odomain (keys(%cookies)) {
7854
foreach $opath (keys(%{$cookies{$odomain}})) {
7855
foreach $ocook (keys(%{$cookies{$odomain}{$opath}})) {
7856
my %deref = %{$cookies{$odomain}{$opath}{$ocook}};
7857
print COOKFILE join("\t", $odomain, 'FALSE', $opath,
7858
$deref{secure} ? "TRUE" : "FALSE", $deref{expires}, $ocook,
7859
$deref{value}), "\n" if $deref{expires} > $nowtime;
7860
}
7861
}
7862
}
7863
} # rewrite file
7864
close COOKFILE;
7865
} # fillJar
7866
7867
#*********************************************************************
7868
# Web Express features. For more on Web Express, visit
7869
# http://www.webexpresstech.com/WebXP/WebExpressTutorial.html
7870
#*********************************************************************
7871
7872
sub webExpress($)
7873
{
7874
my $line = shift;
7875
stripWhite \$line;
7876
$line =~ s/\s+/ /g;
7877
my $code = $line;
7878
$code =~ s/ .*//;
7879
$line =~ s/.*? //;
7880
defined $shortcut{$code} or
7881
$errorMsg = "shortcut $code is not recognized", return 0;
7882
my $newurl = $shortcut{$code}{url};
7883
7884
# Step through $line and extract options, indicated by -
7885
# This isn't implemented yet.
7886
7887
# Done with options, what remains is the search argument.
7888
my $arg = urlEncode $line;
7889
length $arg or
7890
$errorMsg = "shortcut is given no search argument", return 0;
7891
7892
# Put the argument into the url.
7893
$newurl =~ s/\$1/$arg/;
7894
7895
return 1, $newurl, $shortcut{$code}{after};
7896
} # webExpress
7897
7898
7899
# return "x" if an error is encountered
7900
sub parseWWWAuth($$)
7901
{
7902
my ($authline, $url_desc) = @_;
7903
my ($qop_auth, $qop_authint) = (0, 1); # this would be an enum in C
7904
my ($username, $pass);
7905
7906
# parse the authorization request line
7907
my @challenges = ();
7908
my ($attribname, $value);
7909
stripWhite(\$authline);
7910
$authline =~ s/^WWW-Authenticate:\s*//i;
7911
while($authline =~ s/^\s*([^\s]+)\s+//) {
7912
my %challenge = (authscheme => $1);
7913
while($authline =~ s/^([^=]+)=//) {
7914
$attribname = lc($1);
7915
if($authline =~ s/^"//) {
7916
# value of attribute is a quoted string.
7917
$authline =~ s/^([^"]+)"((,\s*)|$)//;
7918
$value = $1;
7919
} else {
7920
$authline =~ s/^([^,]+)((,\s*)|$)//;
7921
$value = $1;
7922
}
7923
$challenge{$attribname} = $value;
7924
}
7925
if($challenge{authscheme} =~ /^digest/i && defined($challenge{qop})) {
7926
my ($q, $newq) = undef;
7927
my @qop = split(/\s*,\s*/, $challenge{qop});
7928
foreach $q (@qop) {
7929
$newq = $qop_authint, last if $q =~ /^auth-int$/i;
7930
}
7931
if(!defined($newq)) {
7932
foreach $q (@qop) {
7933
$newq = $qop_auth, last if $q =~ /^auth$/i;
7934
}
7935
}
7936
$errorMsg = "Server sent a bad qop value in digest authentication", return "x" unless defined $newq;
7937
$challenge{qop} = $newq;
7938
}
7939
push(@challenges, {%challenge});
7940
}
7941
my ($c, $used_challenge) = undef;
7942
# Server may have sent multiple challenges with multiple auth schemes.
7943
# Spec says that we use the strongest scheme supported by the server.
7944
foreach $c (@challenges) {
7945
$used_challenge = $c, last if $$c{authscheme} =~ /^Digest$/i;
7946
}
7947
if(!defined($used_challenge)) {
7948
foreach $c (@challenges) {
7949
$used_challenge = $c if($$c{authscheme} =~ /Basic/);
7950
}
7951
}
7952
$errorMsg = "no usable challenges were found", return "x" unless defined $used_challenge;
7953
if($$used_challenge{authscheme} =~ /Basic/i) {
7954
($username, $pass) = getUserPass($$used_challenge{realm});
7955
return "x" if $username eq "x";
7956
my $do64x = "$username:$pass";
7957
my $do64y = "";
7958
encodeBase64(\$do64x, "", \$do64y);
7959
return "Authorization: Basic $do64y$eol";
7960
}
7961
else { # Not Basic, must be Digest.
7962
unless(eval { require Digest::MD5 }) {
7963
$errorMsg = "You need to download the Digest::MD5 module from CPAN to do digest authentication.", return "x";
7964
}
7965
$errorMsg = "Unsupported algorithm for digest authentication", return "x" if(defined($$used_challenge{algorithm}) && $$used_challenge{algorithm} !~ /^md5$/i);
7966
$errorMsg = "unable to perform digest authentication", return "x" if(!defined($$used_challenge{realm})
7967
|| !defined($$used_challenge{nonce}));
7968
($username, $pass) = getUserPass($$used_challenge{realm});
7969
return "x" if $username eq "x";
7970
srand(time());
7971
my $nc = "00000001";
7972
my $cnonce = sprintf("%08x%08x", int(rand(0xffffffff)), int(rand(0xffffffff)));
7973
# pseudorandoms are fine here. The cnonce is used to thwart chosen plaintext
7974
# attacks when checking integrity of message content. Probably not much
7975
# of a threat for MD5. Maybe it will be someday, and when it is, I'll
7976
# dream up a better way to create a random cnonce.
7977
my ($a1, $a2);
7978
$a1 = "$username:$$used_challenge{realm}:$pass";
7979
if($$used_challenge{qop} == $qop_authint) {
7980
$a2 = $$url_desc{method} . ':' . $$url_desc{PATH} . Digest::MD5::md5_hex($$url_desc{content});
7981
} else {
7982
$a2 = $$url_desc{method} . ':' . $$url_desc{PATH};
7983
}
7984
my $response;
7985
if(defined($$used_challenge{qop})) {
7986
$response = Digest::MD5::md5_hex(Digest::MD5::md5_hex($a1) . ':' . $$used_challenge{nonce} . ':' .
7987
$nc . ':' . $cnonce . ':' .
7988
($$used_challenge{qop} == $qop_auth ? "auth" : "auth-int") . ':' . Digest::MD5::md5_hex($a2)) ;
7989
} else {
7990
$response = Digest::MD5::md5_hex(Digest::MD5::md5_hex($a1) . ':' . $$used_challenge{nonce} . ':' . Digest::MD5::md5_hex($a2)) ;
7991
}
7992
my $out = "Authorization: Digest username=\"$username\", realm=\"$$used_challenge{realm}\", " .
7993
"nonce=\"$$used_challenge{nonce}\", uri=\"$$url_desc{PATH}\", response=\"$response\"";
7994
$out .= ", opaque=\"$$used_challenge{opaque}\"" if defined($$used_challenge{opaque});
7995
$out .= ", algorithm=\"$$used_challenge{algorithm}\"" if defined($$used_challenge{algorithm});
7996
if(defined($$used_challenge{qop})) {
7997
$out .= ", qop=";
7998
$out .= "\"auth\"" if $$used_challenge{qop} == $qop_auth;
7999
$out .= "\"auth-int\"" if $$used_challenge{qop} == $qop_authint;
8000
$out .= ", nc=$nc, cnonce=\"$cnonce\"";
8001
}
8002
$out .= "$eol";
8003
return $out;
8004
}
8005
} # parseWWWAuth
8006
8007
sub getUserPass($)
8008
{
8009
my $realm = shift;
8010
my $abort = "login password sequence aborted";
8011
if(! $authAttempt and defined $authHist{$realm}) {
8012
return split ":", $authHist{$realm};
8013
}
8014
print "Server requests authentication for $realm. (type x to abort)\n";
8015
print "Username: ";
8016
my $username = <STDIN>;
8017
chomp $username;
8018
$errorMsg = $abort, return ("x","x") if $username eq "x";
8019
print "Password: ";
8020
my $pass = <STDIN>;
8021
chomp $pass;
8022
$errorMsg = $abort, return ("x","x") if $pass eq "x";
8023
$authHist{$realm} = "$username:$pass";
8024
return ($username, $pass);
8025
} # getUserPass
8026
8027
Loggerhead is a web-based interface for Breezy
Version: 2.0.1