Issue_10_CGI 000755 047645 000000 00000000000 06547213221 013753 5 ustar 00orwant system 000000 000000 Issue_10_CGI/test.pl 000644 047645 000000 00000004640 06546503150 015354 0 ustar 00orwant system 000000 000000 #!/usr/local/bin/perl
# preliminaries to satisfy taint checks
$ENV{PATH} = '/bin:/usr/bin';
$ENV{IFS} = '';
$PASSWD = "/usr/bin/passwd";
$SU = '/bin/su';
($rv,$msg) = set_passwd('wanda','slutty','test000');
print $msg,"\n";
sub set_passwd ($$$) {
require "chat2.pl";
my $TIMEOUT = 1;
my($user,$old,$new) = @_;
my $h = chat::open_proc($SU,'-c',$PASSWD,$user)
|| return (undef,"Couldn't open $SU -c $PASSWD: $!");
# wait for su's prompt for password
my $rv = &chat::expect($h,$TIMEOUT,
'Password:'=>"'ok'");
$rv eq 'ok' || return (undef,"Didn't get su password prompt.");
chat::print($h,"$old\n");
# wait for prompt for old password
$rv = &chat::expect($h,$TIMEOUT,
'Enter old password:'=>"'ok'",
'incorrect password' =>"'not ok'");
$rv || return (undef,"Didn't get prompt for old password.");
$rv eq 'not ok' && return (undef,"Old password is incorrect.");
# print old password
chat::print($h,"$old\n");
$rv = &chat::expect($h,$TIMEOUT,
'Enter new password: '=>"'ok'",
'Illegal'=>"'not ok'");
$rv || return (undef,"Timed out without seeing prompt for new password.");
$rv eq 'not ok' && return (undef,"Old password is incorrect.");
# print new password
chat::print($h,"$new\n");
($rv,$msg) = &chat::expect($h,$TIMEOUT,
'Re-type new password: ' => "'ok'",
'([\s\S]+)Enter new password:' => "('rejected',\$1)"
);
$rv || return (undef,"Timed out without seeing 2d prompt for new password.");
$rv eq 'rejected' && return (undef,$msg);
# reconfirm password
chat::print($h,"$new\n");
$rv = &chat::expect($h,$TIMEOUT,
'Password changed' => "'ok'");
$rv || return (undef,"Password program failed at very end.");
chat::close($h);
return (1,"Password changed successfully for $Q::user.");
}
sub relinquish_privileges {
$) = $(;
$> = $<;
}
sub create_form {
print
start_form,
table(
TR({align=>RIGHT},
th('User name'), td(textfield(-name=>'user')),
th('Old password'),td(password_field(-name=>'old'))),
TR({align=>RIGHT},
th('New password'),td(password_field(-name=>'new1')),
th('Confirm new password'),td(password_field(-name=>'new2'))),
),
hidden(-name=>'referer',-value=>referer()),
submit('Change Password'),
end_form;
}
sub do_error ($) {
print font({-color=>'red'},b('Error:'),shift," Password not changed.");
}
Issue_10_CGI/passwd 000755 047645 000000 00000010027 06546503145 015267 0 ustar 00orwant system 000000 000000 #!/usr/local/bin/perl -T
# preliminaries to satisfy taint checks
$ENV{PATH} = '/bin:/usr/bin';
$ENV{IFS} = '';
# Prevent buffering problems
$| = 1;
use CGI qw/:standard :html3/;
print header,
start_html(-title=>'Change Unix Password',
-bgcolor=>'white'),
h1('Change your Unix password');
import_names('Q');
TRY: {
last TRY unless $Q::user;
my ($rv,$msg) = check_consistency();
do_error($msg),last TRY unless $rv;
# Change the password, after first temporarily turning off
# an annoying (and irrelevant) error message from su
open(SAVERR,">&STDERR");
open(STDERR,">/dev/null");
($rv,$msg) = set_passwd($Q::user,$Q::old,$Q::new1);
open(STDERR,">&SAVERR");
do_error($msg),last TRY unless $rv;
print $msg;
$OK++;
}
create_form() unless $OK;
print
p,
a({href=>"$Q::referer" || referer() },"[ EXIT SCRIPT ]");
hr,
a({href=>'/'},'Home page'),
end_html;
sub check_consistency {
return (undef,'Please fill in the user name field.') unless $Q::user;
return (undef,'Please fill in the old password field.') unless $Q::old;
return (undef,'Please fill in the new password fields.') unless $Q::new1 && $Q::new2;
return (undef,"New password fields don't match.") unless $Q::new1 eq $Q::new2;
return (undef,"Suspicious user name $Q::user.") unless $Q::user=~/^\w{3,8}$/;
return (undef,'Suspiciously long old password.') unless length($Q::old) < 30;
return (undef,'Suspiciously long new password.') unless length($Q::new1) < 30;
my $uid = (getpwnam($Q::user))[2];
return (undef,"Unknown user name $Q::user.") if $uid eq '';
return (undef,"Can't use this script to set root password.") if $uid == 0;
return 1;
}
sub set_passwd ($$$) {
require "chat2.pl";
my $TIMEOUT = 2;
my $PASSWD = "/usr/bin/passwd";
my $SU = '/bin/su';
my($user,$old,$new) = @_;
my $h = chat::open_proc($SU,'-c',$PASSWD,$user)
|| return (undef,"Couldn't open $SU -c $PASSWD: $!");
# wait for su to prompt for password
my $rv = &chat::expect($h,$TIMEOUT,
'Password:'=>"'ok'",
'user \w+ does not exist'=>"'unknown user'"
);
$rv eq 'unknown user' && return (undef,"User $user unknown.");
$rv || return (undef,"Didn't get su password prompt.");
chat::print($h,"$old\n");
# wait for passwd to prompt for old password
$rv = &chat::expect($h,$TIMEOUT,
'Enter old password:'=>"'ok'",
'incorrect password' =>"'not ok'");
$rv || return (undef,"Didn't get prompt for old password.");
$rv eq 'not ok' && return (undef,"Old password is incorrect.");
# print old password
chat::print($h,"$old\n");
$rv = &chat::expect($h,$TIMEOUT,
'Enter new password: '=>"'ok'",
'Illegal'=>"'not ok'");
$rv || return (undef,"Timed out without seeing prompt for new password.");
$rv eq 'not ok' && return (undef,"Old password is incorrect.");
# print new password
chat::print($h,"$new\n");
($rv,$msg) = &chat::expect($h,$TIMEOUT,
'Re-type new password: ' => "'ok'",
'([\s\S]+)Enter new password:' => "('rejected',\$1)"
);
$rv || return (undef,"Timed out without seeing 2d prompt for new password.");
$rv eq 'rejected' && return (undef,$msg);
# reconfirm password
chat::print($h,"$new\n");
$rv = &chat::expect($h,$TIMEOUT,
'Password changed' => "'ok'");
$rv || return (undef,"Password program failed at very end.");
chat::close($h);
return (1,"Password changed successfully for $Q::user.");
}
sub create_form {
print
start_form,
table(
TR({align=>RIGHT},
th('User name'), td(textfield(-name=>'user')),
th('Old password'),td(password_field(-name=>'old'))),
TR({align=>RIGHT},
th('New password'),td(password_field(-name=>'new1')),
th('Confirm new password'),td(password_field(-name=>'new2'))),
),
hidden(-name=>'referer',-value=>referer()),
submit('Change Password'),
end_form;
}
sub do_error ($) {
print font({-color=>'red',-size=>'+1'},b('Error:'),shift," Password not changed.");
}
Issue_10_Japanese 000755 047645 000000 00000000000 06546503074 015106 5 ustar 00orwant system 000000 000000 Issue_10_Japanese/wwwkan.pl 000644 047645 000000 00000005245 06546502410 017037 0 ustar 00orwant system 000000 000000 #!/usr/bin/perl
#
# wwwkan1.pl - translate kanji or compounds in Japanese HTML.
# Copyright (C) 1997,1998 Tuomas J. Lukka. All rights reserved.
# Directory to the kanji dictionary database
$libdir = "/my/home/dir/japanese_files/";
# The url of this CGI-script, for mangling the links on the page
$my_url = "http://komodo.media.mit.edu/~tjl/cgi-bin/wwwkan1.cgi";
# Link types to substitute.
# 0 = absolute, 1 = through us.
%links = (a => ['href', 1], img => ['src', 0],
form => ['action', 1], link => ['href', 1],
frame => ['src', 1]);
# ---- main program
use CGI;
use LWP::Simple;
use HTML::Parse;
use URI::URL;
use Fcntl;
use AnyDBM_File;
tie %kanji,AnyDBM_File, "$libdir/kanji.dbmx", O_RDONLY, 0;
$query = new CGI;
print $query->header,
"CONVERTED By TJL's kanji explainer on ",`date`,'. Mail comments to lukka@fas.harvard.edu.
',
$query->startform(),
"Go To: ",
$query->textfield(-name => 'url',
-default => 'http://www.yahoo.co.jp/',
-size => 50),
$query->submit('Action','Doit'),
$query->endform,
"
\n";
# Get the original document from the net.
$url = $query->param('url');
$doc = get $url;
# Substitute web addresses so that text documents are fetched with
# this script and pictures are fetched directly.
$h = parse_html($doc);
$h->traverse( sub {
my($e, $start) = @_;
return 1 unless $start;
my $attr = $links{lc $e->tag} or return 1;
my $url = $e->attr($attr->[0]) or return 1;
$e->attr($attr->[0], ($attr->[1] ? getlink($url) : abslink($url)));
}, 1);
$doc = $h->as_HTML;
# Substitute the explanations on each line and print it.
for ( split "\n", $doc ) {
s/((?:[\x80-\xFF][\x40-\xFF])+)/explainstr($1)/ge;
print;
}
exit;
# SUBROUTINES
# Make an absolute URL from a relative URL in the original document
sub abslink {
return (new URI::URL($_[0]))->abs($url)->as_string;
}
# Make a new URL which gets a document through our translation service.
sub getlink {
my $url_to = (new URI::URL($_[0]))->abs($url);
my $proxy_url = new URI::URL($my_url);
$proxy_url->query_form(url => $url_to->as_string);
return $proxy_url->as_string;
}
# Insert explanations into a string of kanjis
sub explainstr {
my $str = @_;
my $res = "";
my ($pos, $mlen, $s);
for ( $pos = 0; $pos < length($str); $pos += $mlen ) {
my $expl;
$mlen = 20;
while (!defined($expl = $kanji{$s=(substr(($str),$pos,$mlen))})
and $mlen > 2) {
$mlen -= 2;
}
$res .= $s;
if (defined $expl) {
$res .= " <[[[".($expl)."]]]> ";
}
}
return $res;
}
Issue_10_Japanese/gendb.pl 000644 047645 000000 00000001667 06546502401 016604 0 ustar 00orwant system 000000 000000 # gendb.pl - generate a database file from the kanji dictionaries.
# Copyright (C) 1997,1998 Tuomas J. Lukka. All rights reserved.
#
# Get the files "kanjidic" and "edict" from
# ftp://ftp.monash.edu.au/pub/nihongo
use AnyDBM_File;
use Fcntl;
$dir = ".";
$dir = $ARGV[0] if defined $ARGV[0];
# Interval to show that we are alive
$report = 4000;
tie %kanji, AnyDBM_File, 'kanji.dbmx', O_CREAT | O_RDWR | O_TRUNC, 0755;
open DIC, "$dir/edict" or die "Can't open $dir/edict";
while () {
next if /^#/;
/^(\S+)\s/ or die("Invalid line '$_'");
$kanji{$1} .= $_;
print("E: $nent '$1'\n") if ++$nent % $report == 0;
}
close DIC;
open DIC, "$dir/kanjidic" or die "Can't open $dir/kanjidic";
while () {
next if /^#/;
s/\s[UNBSMHQLKIOWYXEPCZ][\w-\.]*//g; # Leave G and F
/^(\S+)\s/ or die("Invalid line '$_'");
$kanji{$1} .= $_;
print("K: $nent '$1'\n") if ++$nent % $report == 0;
}
close DIC;
untie %kanji;
Issue_10_OLE 000755 047645 000000 00000000000 06546501274 013777 5 ustar 00orwant system 000000 000000 Issue_10_OLE/code.pl 000644 047645 000000 00000014711 06546501274 015331 0 ustar 00orwant system 000000 000000 use strict;
$| = 1;
my $Contract = 'us8m';
my $text;
if (1) {
# Offline debugging
$text = `cat tsf$Contract.htm`;
}
else {
use LWP::Simple;
my $URL = 'http://www.cbot.com/mplex/quotes/tsfut';
$text = get("$URL/tsf$Contract.htm");
}
my ($Day,$Time,$hhmm,$Open,$High,$Low,$Close,@Bars);
foreach (split "\n", $text) {
my ($Date,$Price,$Hour,$Min,$Sec,$Ind) =
# 03/12/1998 US 98Mar 12116 15:28:34 Open
m|^\s*(\d+/\d+/\d+) # " 03/12/1998"
\s+US\s+\S+\s+(\d+) # " US 98Mar 12116"
\s+(\d+):(\d+):(\d+) # " 12:42:40"
\s*(.*)$|x; # " Ask"
next unless defined $Date;
$Day = $Date;
# Convert from implied fractional to decimal format
$Price = int($Price/100) + ($Price%100)/32;
# Round up time to next multiple of 15 minutes
my $NewTime = int(($Sec+$Min*60+$Hour*3600)/900+1)*900;
if (!defined $Time || $NewTime != $Time) {
push @Bars, [$hhmm, $Open, $High, $Low, $Close]
if defined $Time;
$Open = $High = $Low = $Close = undef;
$Time = $NewTime;
my $Hour = int($Time/3600);
$hhmm = sprintf "%02d:%02d", $Hour, $Time/60-$Hour*60;
}
# Update 15 minute bar values
$Close = $Price;
$Open = $Price unless defined $Open;
$High = $Price unless defined $High && $High > $Price;
$Low = $Price unless defined $Low && $Low < $Price;
}
die "No Times & Sales data found" unless defined $Time;
push @Bars, [$hhmm, $Open, $High, $Low, $Close];
# Start Excel and create new workbook with a single sheet
use Win32::OLE qw(in valof with);
use Win32::OLE::Const 'Microsoft Excel';
use Win32::OLE::NLS qw(:DEFAULT :LANG :SUBLANG);
my $lgid = MAKELANGID(LANG_ENGLISH, SUBLANG_DEFAULT);
$Win32::OLE::LCID = MAKELCID($lgid);
$Win32::OLE::Warn = 3;
print "Start Excel\n";
my $Excel = Win32::OLE->new('Excel.Application', 'Quit');
$Excel->{SheetsInNewWorkbook} = 1;
my $Book = $Excel->Workbooks->Add;
my $Sheet = $Book->Worksheets(1);
$Sheet->{Name} = 'Candle';
# Insert column titles
my $Range = $Sheet->Range("A1:E1");
$Range->{Value} = [qw(Time Open High Low Close)];
$Range->Font->{Bold} = 1;
$Sheet->Columns("A:A")->{NumberFormat} = "h:mm";
# Open/High/Low/Close to be displayed in 32nds
$Sheet->Columns("B:E")->{NumberFormat} = "# ?/32";
# Add 15 minute data to spreadsheet
print "Add data\n";
$Range = $Sheet->Range(sprintf "A2:E%d", 2+$#Bars);
$Range->{Value} = \@Bars;
# Create candle stick chart as new object on worksheet
print "Create chart\n";
$Sheet->Range("A:E")->Select;
my $Chart = $Book->Charts->Add;
$Chart->{ChartType} = xlStockOHLC;
$Chart->Location(xlLocationAsObject, $Sheet->{Name});
# Excel bug: old $Chart has become invalid now!
$Chart = $Excel->ActiveChart;
# Add title, remove legend
with($Chart, HasLegend => 0, HasTitle => 1);
$Chart->ChartTitle->Characters->{Text} = "US T-Bond";
# Setup daily statistics
$Open = $Bars[0][1];
$High = $Sheet->Evaluate("MAX(C:C)");
$Low = $Sheet->Evaluate("MIN(D:D)");
$Close = $Bars[$#Bars][4];
# Change tickmark spacing from decimal to fractional
with($Chart->Axes(xlValue),
HasMajorGridlines => 1,
HasMinorGridlines => 1,
MajorUnit => 1/8,
MinorUnit => 1/16,
MinimumScale => int($Low*16)/16,
MaximumScale => int($High*16+1)/16,
);
# Fat candles with only 5% gaps
$Chart->ChartGroups(1)->{GapWidth} = 5;
sub RGB {
my ($red,$green,$blue) = @_;
return $red | ($green<<8) | ($blue<<16);
}
# White background with a solid border
$Chart->PlotArea->Border->{LineStyle} = xlContinuous;
$Chart->PlotArea->Border->{Color} = RGB(0,0,0);
$Chart->PlotArea->Interior->{Color} = RGB(255,255,255);
# Add 1 hour moving average of the Close series
my $MovAvg = $Chart->SeriesCollection(4)->Trendlines
->Add({Type => xlMovingAvg, Period => 4});
$MovAvg->Border->{Color} = RGB(255,0,0);
# Save worbook to file
print "Save workbook\n";
my $Filename = 'i:\tmp\tpj\data.xls';
unlink $Filename if -f $Filename;
$Book->SaveAs($Filename);
$Book->Close;
############################################################
print "Start ADO and update database\n";
use Win32::OLE::Const 'Microsoft ActiveX Data Objects';
my $Connection = Win32::OLE->new('ADODB.Connection');
my $Recordset = Win32::OLE->new('ADODB.Recordset');
$Connection->Open('T-Bonds');
# Open a recordset for table of this contract
{
local $Win32::OLE::Warn = 0;
$Recordset->Open($Contract, $Connection, adOpenKeyset,
adLockOptimistic, adCmdTable);
}
# Create table and index if it doesn't exist yet
if (Win32::OLE->LastError) {
$Connection->Execute(<<"SQL");
CREATE TABLE $Contract
(
Day DATETIME,
Open DOUBLE, High DOUBLE, Low DOUBLE, Close DOUBLE
)
SQL
$Connection->Execute(<<"SQL");
CREATE INDEX $Contract
ON $Contract (Day) WITH PRIMARY
SQL
$Recordset->Open($Contract, $Connection, adOpenKeyset,
adLockOptimistic, adCmdTable);
}
# Add new record to table
use Win32::OLE::Variant;
$Win32::OLE::Variant::LCID = $Win32::OLE::LCID;
my $Fields = [qw(Day Open High Low Close)];
my $Values = [Variant(VT_DATE, $Day),
$Open, $High, $Low, $Close];
{
local $Win32::OLE::Warn = 0;
$Recordset->AddNew($Fields, $Values);
}
# Replace existing record
if (Win32::OLE->LastError) {
$Recordset->CancelUpdate;
$Recordset->Close;
$Recordset->Open(<<"SQL", $Connection, adOpenDynamic);
SELECT * FROM $Contract
WHERE Day = #$Day#
SQL
$Recordset->Update($Fields, $Values);
}
$Recordset->Close;
$Connection->Close;
############################################################
print "Start Notes and send email\n";
sub EMBED_ATTACHMENT {1454;}
my $Notes = Win32::OLE->new('Notes.NotesSession');
my $Database = $Notes->GetDatabase('', '');
$Database->OpenMail;
my $Document = $Database->CreateDocument;
$Document->{Form} = 'Memo';
$Document->{SendTo} = ['Jon Orwant ',
'Jan Dubois '];
$Document->{Subject} = "US T-Bonds Chart for $Day";
my $Body = $Document->CreateRichtextItem('Body');
$Body->AppendText(<<"EOT");
I\'ve attached the latest US T-Bond data and chart for $Day.
The daily statistics were:
\tOpen\t$Open
\tHigh\t$High
\tLow\t$Low
\tClose\t$Close
Kind regards,
Mary
EOT
$Body->EmbedObject(EMBED_ATTACHMENT, '', $Filename);
#$Document->Send(0);
$Document->Save(0,0);
print "Done\n";
Issue_10_OLE/code2.pl 000644 047645 000000 00000014346 06546501275 015420 0 ustar 00orwant system 000000 000000 use strict;
$| = 1;
my $Contract = 'us8m';
my $text;
if (1) {
# Offline debugging
$text = `cat tsf$Contract.htm`;
}
else {
use LWP::Simple;
my $URL = 'http://www.cbot.com/mplex/quotes/tsfut';
$text = get("$URL/tsf$Contract.htm");
}
my ($Day,$Time,$hhmm,$Open,$High,$Low,$Close,@Bars);
foreach (split "\n", $text) {
my ($Date,$Price,$Hour,$Min,$Sec,$Ind) =
# 03/12/1998 US 98Mar 12116 15:28:34 Open
m|^\s*(\d+/\d+/\d+) # " 03/12/1998"
\s+US\s+\S+\s+(\d+) # " US 98Mar 12116"
\s+(\d+):(\d+):(\d+) # " 12:42:40"
\s*(.*)$|x; # " Ask"
next unless defined $Date;
$Day = $Date;
# Convert from implied fractional to decimal format
$Price = int($Price/100) + ($Price%100)/32;
# Round up time to next multiple of 15 minutes
my $NewTime = int(($Sec+$Min*60+$Hour*3600)/900+1)*900;
if (!defined $Time || $NewTime != $Time) {
push @Bars, [$hhmm, $Open, $High, $Low, $Close]
if defined $Time;
$Open = $High = $Low = $Close = undef;
$Time = $NewTime;
my $Hour = int($Time/3600);
$hhmm = sprintf "%02d:%02d", $Hour, $Time/60-$Hour*60;
}
# Update 15 minute bar values
$Close = $Price;
$Open = $Price unless defined $Open;
$High = $Price unless defined $High && $High > $Price;
$Low = $Price unless defined $Low && $Low < $Price;
}
die "No Times & Sales data found" unless defined $Time;
push @Bars, [$hhmm, $Open, $High, $Low, $Close];
# Start Excel and create new workbook with a single sheet
use Win32::OLE qw(in valof with);
use Win32::OLE::Const 'Microsoft Excel';
use Win32::OLE::NLS qw(:DEFAULT :LANG :SUBLANG);
my $lgid = MAKELANGID(LANG_ENGLISH, SUBLANG_DEFAULT);
$Win32::OLE::LCID = MAKELCID($lgid);
$Win32::OLE::Warn = 3;
print "Start Excel\n";
my $Excel = Win32::OLE->new('Excel.Application', 'Quit');
$Excel->{SheetsInNewWorkbook} = 1;
my $Book = $Excel->Workbooks->Add;
my $Sheet = $Book->Worksheets(1);
$Sheet->{Name} = 'Candle';
# Insert column titles
my $Range = $Sheet->Range("A1:E1");
$Range->{Value} = [qw(Time Open High Low Close)];
$Range->Font->{Bold} = 1;
$Sheet->Columns("A:A")->{NumberFormat} = "h:mm";
# Open/High/Low/Close to be displayed in 32nds
$Sheet->Columns("B:E")->{NumberFormat} = "# ?/32";
# Add 15 minute data to spreadsheet
print "Add data\n";
$Range = $Sheet->Range(sprintf "A2:E%d", 2+$#Bars);
$Range->{Value} = \@Bars;
# Create candle stick chart as new object on worksheet
print "Create chart\n";
$Sheet->Range("A:E")->Select;
my $Chart = $Book->Charts->Add;
$Chart->{ChartType} = xlStockOHLC;
$Chart->Location(xlLocationAsObject, $Sheet->{Name});
# Excel bug: old $Chart has become invalid now!
$Chart = $Excel->ActiveChart;
# Add title, remove legend
with($Chart, HasLegend => 0, HasTitle => 1);
$Chart->ChartTitle->Characters->{Text} = "US T-Bond";
# Setup daily statistics
$Open = $Bars[0][1];
$High = $Sheet->Evaluate("MAX(C:C)");
$Low = $Sheet->Evaluate("MIN(D:D)");
$Close = $Bars[$#Bars][4];
# Change tickmark spacing from decimal to fractional
with($Chart->Axes(xlValue),
HasMajorGridlines => 1,
HasMinorGridlines => 1,
MajorUnit => 1/8,
MinorUnit => 1/16,
MinimumScale => int($Low*16)/16,
MaximumScale => int($High*16+1)/16,
);
# Fat candles with only 5% gaps
$Chart->ChartGroups(1)->{GapWidth} = 5;
sub RGB {
my ($red,$green,$blue) = @_;
return $red | ($green<<8) | ($blue<<16);
}
# White background with a solid border
$Chart->PlotArea->Border->{LineStyle} = xlContinuous;
$Chart->PlotArea->Border->{Color} = RGB(0,0,0);
$Chart->PlotArea->Interior->{Color} = RGB(255,255,255);
# Add 1 hour moving average of the Close series
my $MovAvg = $Chart->SeriesCollection(4)->Trendlines
->Add({Type => xlMovingAvg, Period => 4});
$MovAvg->Border->{Color} = RGB(255,0,0);
# Save worbook to file
print "Save workbook\n";
my $Filename = 'i:\tmp\tpj\data.xls';
unlink $Filename if -f $Filename;
$Book->SaveAs($Filename);
$Book->Close;
############################################################
print "Start ADO and update database\n";
use Win32::OLE::Const 'Microsoft ActiveX Data Objects';
my $Connection = Win32::OLE->new('ADODB.Connection');
my $Recordset = Win32::OLE->new('ADODB.Recordset');
$Connection->Open('T-Bonds');
# Open a recordset for table of this contract
{
local $Win32::OLE::Warn = 0;
$Recordset->Open($Contract, $Connection, adOpenKeyset,
adLockOptimistic, adCmdTable);
}
# Create table and index if it doesn't exist yet
if (Win32::OLE->LastError) {
$Connection->Execute(<<"SQL");
CREATE TABLE $Contract
(
Day DATETIME,
Open DOUBLE, High DOUBLE, Low DOUBLE, Close DOUBLE
)
SQL
$Connection->Execute(<<"SQL");
CREATE INDEX $Contract
ON $Contract (Day) WITH PRIMARY
SQL
$Recordset->Open($Contract, $Connection, adOpenKeyset,
adLockOptimistic, adCmdTable);
}
# Add new record to table
use Win32::OLE::Variant;
$Win32::OLE::Variant::LCID = $Win32::OLE::LCID;
my $Fields = [qw(Day Open High Low Close)];
my $Values = [Variant(VT_DATE, $Day),
$Open, $High, $Low, $Close];
{
local $Win32::OLE::Warn = 0;
$Recordset->AddNew($Fields, $Values);
}
# Replace existing record
if (Win32::OLE->LastError) {
$Recordset->CancelUpdate;
$Recordset->Close;
$Recordset->Open(<<"SQL", $Connection, adOpenDynamic);
SELECT * FROM $Contract
WHERE Day = #$Day#
SQL
$Recordset->Update($Fields, $Values);
}
$Recordset->Close;
$Connection->Close;
############################################################
print "Start Notes and send email\n";
sub EMBED_ATTACHMENT {1454;}
my $Notes = Win32::OLE->new('Notes.NotesSession');
my $Database = $Notes->GetDatabase('', '');
$Database->OpenMail;
my $Document = $Database->CreateDocument;
$Document->{Form} = 'Memo';
$Document->{SendTo} = ['Jon Orwant ',
'Jan Dubois '];
$Document->{Subject} = "US T-Bonds Chart for $Day";
my $Body = $Document->CreateRichtextItem('Body');
$Body->AppendText(<<"EOT");
I\'ve attached the latest US T-Bond data and chart for $Day.
The daily statistics were:
\tOpen\t$Open
\tHigh\t$High
\tLow\t$Low
\tClose\t$Close
Kind regards,
Mary
EOT
$Body->EmbedObject(EMBED_ATTACHMENT, '', $Filename);
#$Document->Send(0);
$Document->Save(0,0);
print "Done\n";
Issue_10_RayTrace 000755 047645 000000 00000000000 06547215617 015076 5 ustar 00orwant system 000000 000000 Issue_10_RayTrace/tracer.pl 000755 047645 000000 00000030135 06547214241 016767 0 ustar 00orwant system 000000 000000 #!/usr/bin/perl
# -*- mode: perl; perl-indent-level: 2 -*-
#
# Simple ray tracer in Perl
# Author: Mark-Jason Dominus (mjd-perl-raytracer@plover.com)
#
# This program is in the PUBLIC DOMAIN
#
use Carp;
use FileHandle;
STDERR->autoflush(1);
require 'getopts.pl';
# Options:
# -p position and facing of viewpoint in the form:
# xpos,ypos,facing
# where `facing' is 0=north, 90=east
# -X, -Y Width and height of output, in pixels
# -d distance to `screen'
# -a range of vision angle
# -D enable debug mode
# -G grayscale mode
&Getopts('DP:X:Y:d:a:G');
$DEBUG = $opt_D;
$pi = 3.1415926535897932386;
$FAR_AWAY = 1_000_000_000; # Nothing is this far away.
# Get coordinates of viewpoint, and facing
# use command-line argument if available; default to
# 0,0 and north-facing if not.
($vx, $vy, $vf) = (split(/,/, $opt_P), 0, 0, 0);
# Normalize $vf to internal compass: Radians, with 0 meaning east and
# increasing counterclockwise
$vf = (90 - $vf) * $pi / 180;
$v = [ $vx, $vy ];
# Half of range vision angle
$va = ($opt_a*$pi/360) || ($pi / 4);
croak "Bad viewing angle---use number between 0 and 180.\n"
unless $va > 0 && $va < $pi / 2;
# Get dimensions of output.
$X = $opt_x || 320;
$Y = $opt_y || 200;
# Distance to screen
$D = $opt_d || 1;
my $infile = shift;
die "Usage: $0 infile [outfile]\n"
unless defined $infile;
my $outfile = shift;
if (defined $outfile) {
open(OUT, "> $outfile")
or die "Couldn't open output file `$outfile' for writing: $!; aborting";
$outh = \*OUT;
} else {
$outh = \*STDOUT;
}
open (I, "< $infile")
or die "Couldn't open input file `$infile': $!; aborting";
while () {
s/\#.*//;
next unless /\S/;
my @coords = split;
unless (@coords == 5) {
my $n = @coords;
warn "Line $. of input file `$infile' has $n fields instead of 5. Skipping.\n";
next;
}
my ($x1, $y1, $x2, $y2, $c) = @coords;
push @lines, [Segment([$x1, $y1], [$x2, $y2]),
{ID => $.,
COLOR => HueToRGB($c),
HEIGHT => 1,
MAX_INTENSITY => -$FAR_AWAY,
MIN_INTENSITY => $FAR_AWAY,
MAX_DISTANCE => -$FAR_AWAY,
MIN_DISTANCE => $FAR_AWAY,
}
];
}
close I;
#
# This would be a good place to preprocess the @lines list
# so that the closest lines come first.
#
{
# Unit vector in the direction you are facing
my $uf = UnitVector($vf);
# Midpoint of screen
my $sm = VectorSum($v, ScalarProd($D, $uf));
# Left and right endpoints of screen
$sl = VectorSum($sm, ScalarProd($D*tan($va), Left($uf)));
$sr = VectorSum($sm, ScalarProd($D*tan($va), Right($uf)));
}
# Create the canvas:
{
my @c = ("\xff" x (3*$X)) x $Y;
$canvas = \@c;
}
# Main loop
# $p is the pixel of the screen that we're going to draw now
for ($p=0; $p < $X; $p++) {
print STDERR "." if ($p+1) % 50 == 0;
print STDERR "$p\n" if $DEBUG;
# Point of the screen that we're shooting through
my $sp = Partway($sl, $sr, $p/($X-1));
my $dsp = Distance($sp, $v); # Distance to $sp
my $los = Ray($v, $sp);
my $closest_line_distance = $FAR_AWAY;
my ($closest_line, $closest_line_intersection);
# And what do we see in *this* direction?
foreach $line (@lines) {
my ($segment, $lineinfo) = @$line;
my $intersection = TrueIntersection($los, $segment);
next unless defined $intersection;
my $d = Distance($intersection->[0], $v);
next unless $d < $closest_line_distance;
if ($d < $dsp) {
# Clip walls inside the viewplane
warn "Line $line->[2]{ID} is inside the viewplane at col. $p; clipping.\n"
unless $clipped{$line->[2]{ID}}++;
next;
}
$closest_line_distance = $d;
$closest_line = $line;
$closest_line_intersection = $intersection->[0];
}
# If we didn't see anything, don't render it.
next unless $closest_line;
next unless $closest_line_distance < $FAR_AWAY;
die "Closest line distance negative ($closest_line_distance) at p=$p; aborting"
if $closest_line_distance < 0;
# Compute the height of the thing we see, in pixels.
# Height is inversely proportional to distance.
# The screen has height 1; an object twice as far as the screen has
# height 1/2, etc.
# my $h = $Y * $D / $closest_line_distance;
# But actually it looks funny if we do this because we don't usually
# see things long enuogh to exhibit this behavior.
# BUG HERE - Don't use Y coord; use distance in direction
# perpendicular to screen.
# NO, that's the same mistake you made in 1995.
# George pointed out that you need to make h = D / d,
# where D is the distance to the wall, and d is the distance to
# the screen. (screen = `viewplane')
# my $h = $Y * $D / ($closest_line_intersection->[1]);
# my $h = $Y * $D / DotProd(VectorSum($closest_line_intersection,
# Minus($v)),
# UnitVector(RayDirection($los))
# );
my ($segment, $lineinfo) = @$closest_line;
my $h = $Y * $dsp / $closest_line_distance;
# Compute the color of the thing we see.
my ($r, $g, $b) = @{$lineinfo->{COLOR}};
my $intensity = 2 / sqrt($closest_line_distance);
if ($DEBUG) {
$lineinfo->{MAX_INTENSITY} = $intensity
if $lineinfo->{MAX_INTENSITY} < $intensity;
$lineinfo->{MIN_INTENSITY} = $intensity
if $lineinfo->{MIN_INTENSITY} > $intensity;
$lineinfo->{MAX_DISTANCE} = $closest_line_distance
if $lineinfo->{MAX_DISTANCE} < $closest_line_distance;
$lineinfo->{MIN_DISTANCE} = $closest_line_distance
if $lineinfo->{MIN_DISTANCE} > $closest_line_distance;
$lineinfo->{MAX_HEIGHT} = $h
if $lineinfo->{MAX_HEIGHT} < $h;
$lineinfo->{MIN_HEIGHT} = $h
if $lineinfo->{MIN_HEIGHT} > $h;
}
my $colorstr;
if ($previous_closest_line ne $lineinfo->{ID}) {
$colorstr = "\x0\x0\x0";
} else {
for ($r, $g, $b) {
my $i = $_ * $intensity * 256;
if ($i < 0) {
$i = 0;
} elsif ($i > 255) {
$i = 255;
}
$colorstr .= chr($i);
}
}
my $bot = $Y/2 + $h/2;
my $top = $bot - $lineinfo->{HEIGHT} * $Y * $dsp / $closest_line_distance;
Render($canvas, $p, $top, $bot, $colorstr);
$previous_closest_line = $lineinfo->{ID};
}
print STDERR "\n";
if ($DEBUG) {
foreach $line (@lines) {
my $lineinfo = $line->[1];
print STDERR sprintf "%02d %2.2f %2.2f %2.2f %2.2f %2.2f %2.2f\n",
@{$lineinfo}{qw(ID MIN_INTENSITY MAX_INTENSITY MIN_DISTANCE MAX_DISTANCE MIN_HEIGHT MAX_HEIGHT)};
}
}
DisplayCanvas($outh, $canvas);
################################################################
#
# Graphics subroutines
#
################################################################
# Convert my totally arbitrary hue number [0..360)
# to a set of RGB values.
sub HueToRGB {
my $hue = shift;
# Handle out of range. $hue is now in [0, 360).
$hue = $hue - 360 * int($hue / 360);
my ($r, $g, $b);
if ($hue < 120) { # Red-yellow-green area
$r = (120 - $hue) / 120;
$g = $hue / 120;
$b = 0;
} elsif ($hue < 240) { # Green-cyan-blue area
$r = 0;
$g = (240 - $hue) / 120;
$b = ($hue - 120) / 120;
} else { # Blue-magenta-red area
$r = ($hue - 240) / 120;
$g = 0;
$b = (360 - $hue) / 120;
}
print STDERR "Hue $hue => ($r, $g, $b)\n";
if ($opt_G) { # Convert to grayscale
$r = $g = $b = 0.30 * $r + 0.59 * $g + 0.11 * $b;
}
[$r, $g, $b];
}
# Arguments:
# Canvas
# column number
# height of object (pixels)
# Color of object (3-char string)
sub Render {
my $c = shift;
my $n = shift;
my $top = shift;
my $bot = shift;
my $color = shift;
my $y;
$top = 0 if $top < 0;
$bot = $Y - 1 if $bot >= $Y;
if ($color eq "\xff\xff\xff") {
warn "At column $n the color is white.\n";
}
for ($y = $top; $y <= $bot; $y++) {
substr($c->[$y], 3*$n, 3) = $color;
}
}
# Print out the canvas in PPM format to the filehandle specified
sub DisplayCanvas {
my $fh = shift;
my $canvas = shift;
print $fh "P6\n$X $Y\n255\n";
print $fh @$canvas;
}
################################################################
#
# Utility subroutines
#
################################################################
# tangent function
sub tan {
sin($_[0]) / cos($_[0]);
}
# Direction of a ray
sub RayDirection {
my $l = shift;
my $type = $l->[2];
croak "Asked for direction of a `$type' which should have been a RAY.\n"
unless $type eq RAY;
my $endpoint = $l->[0];
my $farpoint = $l->[1];
my $xd = $farpoint->[0] - $endpoint->[0];
my $yd = $farpoint->[1] - $endpoint->[1];
my $rad = atan2($yd, $xd);
$rad += 2*$pi if $rad < 0;
$rad;
}
# Return the unit vector in a certain direction
sub UnitVector {
my $d = shift;
[ cos $d, sin $d ];
}
# Rotate a vector a quarter-turn counterclockwise
sub Left {
my $v = shift;
[ - $v->[1], $v->[0] ];
}
# Rotate a vector a quarter-turn clockwise
sub Right {
my $v = shift;
[ $v->[1], - $v->[0] ];
}
# Rotate a vector a half turn
sub Minus {
my $v = shift;
[ - $v->[0], - $v->[1] ];
}
# Given two points, and a fraction t find the point that is `t' of
# the way between the two points
sub Partway {
my $p1 = shift;
my $p2 = shift;
my $t = shift;
[($p1->[0] * (1-$t)) + ($p2->[0] * $t),
($p1->[1] * (1-$t)) + ($p2->[1] * $t)
];
}
# Multiply a vector by a scalar
sub ScalarProd {
my $s = shift;
my $v = shift;
[ $v->[0] * $s, $v->[1] * $s ];
}
# Dot product of two vectors
sub DotProd {
my $v1 = shift;
my $v2 = shift;
$v1->[0] * $v2->[0] + $v1->[1] * $v2->[1];
}
# Sum of vectors
sub VectorSum {
my ($x, $y) = (0, 0);
for (@_) {
$x += $_->[0];
$y += $_->[1];
}
[ $x, $y ];
}
# Build a ray.
# Accept two points as arguments; first is endpoint,
# second is in the direction of the ray.
sub Ray {
[ $_[0], $_[1], RAY ];
}
# Build a line.
# Accept two points as arguments; the line passes through these
sub Line {
[ $_[0], $_[1], LINE ];
}
# Build a line segment.
# Accept two points as arguments; these are the endpoints
sub Segment {
[ $_[0], $_[1], SEGMENT ];
}
# Given a line and a point, find the parameter of the point if it
# lies on the line
sub ParamOf {
my $p = shift;
my $l = shift;
my $l1 = $l->[0];
my $l2 = $l->[1];
my $v = VectorSum($l2, Minus($l1));
croak "Line [($l1->[0],$l1->[1]), ($l2->[0],$l2->[1])] is ill-defined. Aborting"
if IsZero($v);
# Line is now a ray defined by $l1 and $v.
if ($v->[0] == 0) { # Vertical line
return undef unless $p->[0] == $l1->[0];
($p->[1] - $l1->[1])/ $v->[1];
} elsif ($v->[1] == 0) { # Horizontal line
return undef unless $p->[1] == $l1->[1];
($p->[0] - $l1->[0])/ $v->[0];
} else { # Diagonal line
my $tx = ($p->[0] - $l1->[0])/ $v->[0];
my $ty = ($p->[1] - $l1->[1])/ $v->[1];
return undef unless $tx == $ty;
$tx;
}
}
# Figure out if two lines intersect.
sub TrueIntersection {
my @ret = my ($INTERSECTION, $t1, $t2) = Intersection(@_);
return undef unless ParamIsGood($t1, $_[0]);
return undef unless ParamIsGood($t2, $_[1]);
\@ret;
}
# Figure out if two lines would intersect if infinitely extended.
# Return undef if there is no intersection.
# Otherwise, return ([X, Y], T1, T2).
# [X, Y] is the intersection point.
# T1 and T2 are the position of the intersection point
# on the first and second lines, respectively.
sub Intersection {
my $l1 = shift;
my $l2 = shift;
my ($bp1, $op1) = @$l1;
my ($bp2, $op2) = @$l2;
my $v1 = VectorSum($op1, Minus($bp1));
my $v2 = VectorSum($op2, Minus($bp2));
my ($x1, $y1) = @$v1;
my ($x2, $y2) = @$v2;
my $DEN = $x1 * $y2 - $x2 * $y1;
# Lines are parallel.
return undef if $DEN == 0;
my ($bx1, $by1) = @$bp1;
my ($bx2, $by2) = @$bp2;
my $t1 = (($bx2 - $bx1) * $y2 - ($by2 - $by1) * $x2) / $DEN;
my $t2 = (($bx2 - $bx1) * $y1 - ($by2 - $by1) * $x1) / $DEN;
my $RESULT = VectorSum($bp1, ScalarProd($t1, $v1));
($RESULT, $t1, $t2);
}
# Is this a suitable parameter for this line?
sub ParamIsGood {
my $t = shift;
my $ln = shift;
my $type = $ln->[2];
return $type eq LINE
|| $type eq RAY && $t >= 0
|| $type eq SEGMENT && $t >= 0 && $t <= 1;
}
# Distance between two points
sub Distance {
my $p1 = shift;
my $p2 = shift;
my ($x1, $y1) = @$p1;
my ($x2, $y2) = @$p2;
sqrt(($x1-$x2)*($x1-$x2) + ($y1-$y2)*($y1-$y2));
}
# Length of a vector
sub Length {
my $p1 = shift;
sqrt($p1->[0]**2 + $p1->[1]**2);
}
Issue_10_RayTrace/1.map 000644 047645 000000 00000000021 06547214234 015777 0 ustar 00orwant system 000000 000000 -2 3 2 4 0 Issue_10_RayTrace/complicated.map 000644 047645 000000 00000000166 06547214234 020135 0 ustar 00orwant system 000000 000000 # Triangular box
4 4 6 4 0
6 4 6 6 0
6 6 4 4 0
# Wall behind it
5 5 5 8 40
# Angled backdrop
0 5 5 8 80
2 2 0 5 120
Issue_10_RayTrace/cross.map 000644 047645 000000 00000000170 06547214234 016775 0 ustar 00orwant system 000000 000000 2 5 6 5 15 1
6 5 5 2 75 1
5 2 8 0 135 1
8 0 0 0 195 1
0 0 3 2 255 1
3 2 2 5 300 1
Issue_10_RayTrace/demo.map 000644 047645 000000 00000000104 06547214234 016565 0 ustar 00orwant system 000000 000000 0 4 1 4 120
1 4 3 8 120
4 8 12 4 120 Issue_10_RayTrace/demo2.map 000644 047645 000000 00000000276 06547214235 016662 0 ustar 00orwant system 000000 000000 0 4 1 4 120
1 4 3 8 120
4 8 5.75 2.75 120
5.75 2.75 12 2.75 120
#6 4 7 1 0
2 6 2.5 2.5 120
Issue_10_RayTrace/dist.map 000644 047645 000000 00000000137 06547214235 016613 0 ustar 00orwant system 000000 000000 -7 7 7 7 0
-5 6 5 6 90
-3 5 3 5 180
-1 4 1 4 270
Issue_10_RayTrace/square.map 000644 047645 000000 00000000061 06547214241 017141 0 ustar 00orwant system 000000 000000 -3 2 -3 20 60
-3 20 3 20 180
3 2 3 20 300
Issue_10_Threads 000755 047645 000000 00000000000 06547214743 014755 5 ustar 00orwant system 000000 000000 Issue_10_Threads/primes 000644 047645 000000 00000001267 06547214743 016264 0 ustar 00orwant system 000000 000000 #!/usr/bin/perl -w
# prime-pthread, courtesy of Tom Christiansen
use strict;
use Thread;
use Thread::Queue;
my $stream = new Thread::Queue;
my $kid = new Thread(\&check_num, $stream, 2);
for my $i ( 3 .. 1000 ) {
$stream->enqueue($i);
}
$stream->enqueue(undef);
$kid->join();
sub check_num {
my ($upstream, $cur_prime) = @_;
my $kid;
my $downstream = new Thread::Queue;
while (my $num = $upstream->dequeue) {
next unless $num % $cur_prime;
if ($kid) {
$downstream->enqueue($num);
} else {
print "Found prime $num\n";
$kid = new Thread(\&check_num, $downstream, $num);
}
}
$downstream->enqueue(undef) if $kid;
$kid->join() if $kid;
}
Issue_10_Threads/primes~ 000644 047645 000000 00000001272 06547214705 016454 0 ustar 00orwant system 000000 000000 #!/usr/bin/perl -w
# prime-pthread, courtesy of Tom Christiansen
use strict;
use Thread;
use Thread::Queue;
my $stream = new Thread::Queue;
my $kid = new Thread(\&check_num, $stream, 2);
for my $i ( 3 .. 1000 ) {
$stream->enqueue($i);
}
$stream->enqueue(undef);
$kid->join();
sub check_num {
my ($upstream, $cur_prime) = @_;
my $kid;
my $downstream = new Thread::Queue;
while (my $num = $upstream->dequeue) {
next unless $num % $cur_prime;
if ($kid) {
$downstream->enqueue($num);
} else {
print "Found prime $num\n";
$kid = new Thread(\&check_num, $downstream, $num);
}
}
$downstream->enqueue(undef) if $kid;
$kid->join() if $kid;
}
# Triangular box
4 4 6 4 0
6 4 6 6 0
6 6 4 4 0
# Wall behind it
5 5 5 8 40
# Angled backdrop
0 5 5 8 80
2 2 0 5 120
Issue_10_RayTrace/cross.map 000644 047645 000000 00000000170 06547214234 016775 0 ustar 00orwant system 000000 000000 2 5 6 5 15 1
6 5 5 2 75 1
5 2 8 0 135 1
8 0 0 0 195 1
0 0 3 2 255 1
3 2 2 5 300 1
Issue_10_RayTrace/demo.map 000644 047645 000000 00000000104 06547214234 016565 0 ustar 00orwant system 000000 000000 0 4 1 4 120
1 4 3 8 120
4 8 12 4 120 Issue_10_RayTrace/demo2.map 000644 047645 000000 00000000276 06547214235 016662 0 ustar 00orwant system 000000 000000 0 4 1 4 120
1 4 3 8 120
4 8 5.75 2.75 120
5.75 2.75 12 2.75 120
#6 4 7 1 0
2 6 2.5 2.5 120
Issue_10_RayTrace/dist.map 000644 047645 000000 00000000137 06547214235 016613 0 ustar 00orwant system 000000 000000 -7 7 7 7 0
-5 6 5 6 90
-3 5 3 5 180
-1 4 1 4 270
Issue_10_RayTrace/square.map 000644 047645 000000 00000000061 06547214241 017141 0 ustar 00orwant system 000000 000000 -3 2 -3 20 60
-3 20 3 20 180
3 2 3 20 300
Issue_10_Threads 000755 047645 000000 00000000000 06547214743 014755 5 ustar 00orwant system 000000 000000 Issue_10_Threads/primes 000644 047645 000000 00000001267 06547214743 016264 0 ustar 00orwant system 000000 000000