This file is indexed.

/usr/share/perl5/News/Article.pm is in libnews-article-perl 1.27-8.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

   1
   2
   3
   4
   5
   6
   7
   8
   9
  10
  11
  12
  13
  14
  15
  16
  17
  18
  19
  20
  21
  22
  23
  24
  25
  26
  27
  28
  29
  30
  31
  32
  33
  34
  35
  36
  37
  38
  39
  40
  41
  42
  43
  44
  45
  46
  47
  48
  49
  50
  51
  52
  53
  54
  55
  56
  57
  58
  59
  60
  61
  62
  63
  64
  65
  66
  67
  68
  69
  70
  71
  72
  73
  74
  75
  76
  77
  78
  79
  80
  81
  82
  83
  84
  85
  86
  87
  88
  89
  90
  91
  92
  93
  94
  95
  96
  97
  98
  99
 100
 101
 102
 103
 104
 105
 106
 107
 108
 109
 110
 111
 112
 113
 114
 115
 116
 117
 118
 119
 120
 121
 122
 123
 124
 125
 126
 127
 128
 129
 130
 131
 132
 133
 134
 135
 136
 137
 138
 139
 140
 141
 142
 143
 144
 145
 146
 147
 148
 149
 150
 151
 152
 153
 154
 155
 156
 157
 158
 159
 160
 161
 162
 163
 164
 165
 166
 167
 168
 169
 170
 171
 172
 173
 174
 175
 176
 177
 178
 179
 180
 181
 182
 183
 184
 185
 186
 187
 188
 189
 190
 191
 192
 193
 194
 195
 196
 197
 198
 199
 200
 201
 202
 203
 204
 205
 206
 207
 208
 209
 210
 211
 212
 213
 214
 215
 216
 217
 218
 219
 220
 221
 222
 223
 224
 225
 226
 227
 228
 229
 230
 231
 232
 233
 234
 235
 236
 237
 238
 239
 240
 241
 242
 243
 244
 245
 246
 247
 248
 249
 250
 251
 252
 253
 254
 255
 256
 257
 258
 259
 260
 261
 262
 263
 264
 265
 266
 267
 268
 269
 270
 271
 272
 273
 274
 275
 276
 277
 278
 279
 280
 281
 282
 283
 284
 285
 286
 287
 288
 289
 290
 291
 292
 293
 294
 295
 296
 297
 298
 299
 300
 301
 302
 303
 304
 305
 306
 307
 308
 309
 310
 311
 312
 313
 314
 315
 316
 317
 318
 319
 320
 321
 322
 323
 324
 325
 326
 327
 328
 329
 330
 331
 332
 333
 334
 335
 336
 337
 338
 339
 340
 341
 342
 343
 344
 345
 346
 347
 348
 349
 350
 351
 352
 353
 354
 355
 356
 357
 358
 359
 360
 361
 362
 363
 364
 365
 366
 367
 368
 369
 370
 371
 372
 373
 374
 375
 376
 377
 378
 379
 380
 381
 382
 383
 384
 385
 386
 387
 388
 389
 390
 391
 392
 393
 394
 395
 396
 397
 398
 399
 400
 401
 402
 403
 404
 405
 406
 407
 408
 409
 410
 411
 412
 413
 414
 415
 416
 417
 418
 419
 420
 421
 422
 423
 424
 425
 426
 427
 428
 429
 430
 431
 432
 433
 434
 435
 436
 437
 438
 439
 440
 441
 442
 443
 444
 445
 446
 447
 448
 449
 450
 451
 452
 453
 454
 455
 456
 457
 458
 459
 460
 461
 462
 463
 464
 465
 466
 467
 468
 469
 470
 471
 472
 473
 474
 475
 476
 477
 478
 479
 480
 481
 482
 483
 484
 485
 486
 487
 488
 489
 490
 491
 492
 493
 494
 495
 496
 497
 498
 499
 500
 501
 502
 503
 504
 505
 506
 507
 508
 509
 510
 511
 512
 513
 514
 515
 516
 517
 518
 519
 520
 521
 522
 523
 524
 525
 526
 527
 528
 529
 530
 531
 532
 533
 534
 535
 536
 537
 538
 539
 540
 541
 542
 543
 544
 545
 546
 547
 548
 549
 550
 551
 552
 553
 554
 555
 556
 557
 558
 559
 560
 561
 562
 563
 564
 565
 566
 567
 568
 569
 570
 571
 572
 573
 574
 575
 576
 577
 578
 579
 580
 581
 582
 583
 584
 585
 586
 587
 588
 589
 590
 591
 592
 593
 594
 595
 596
 597
 598
 599
 600
 601
 602
 603
 604
 605
 606
 607
 608
 609
 610
 611
 612
 613
 614
 615
 616
 617
 618
 619
 620
 621
 622
 623
 624
 625
 626
 627
 628
 629
 630
 631
 632
 633
 634
 635
 636
 637
 638
 639
 640
 641
 642
 643
 644
 645
 646
 647
 648
 649
 650
 651
 652
 653
 654
 655
 656
 657
 658
 659
 660
 661
 662
 663
 664
 665
 666
 667
 668
 669
 670
 671
 672
 673
 674
 675
 676
 677
 678
 679
 680
 681
 682
 683
 684
 685
 686
 687
 688
 689
 690
 691
 692
 693
 694
 695
 696
 697
 698
 699
 700
 701
 702
 703
 704
 705
 706
 707
 708
 709
 710
 711
 712
 713
 714
 715
 716
 717
 718
 719
 720
 721
 722
 723
 724
 725
 726
 727
 728
 729
 730
 731
 732
 733
 734
 735
 736
 737
 738
 739
 740
 741
 742
 743
 744
 745
 746
 747
 748
 749
 750
 751
 752
 753
 754
 755
 756
 757
 758
 759
 760
 761
 762
 763
 764
 765
 766
 767
 768
 769
 770
 771
 772
 773
 774
 775
 776
 777
 778
 779
 780
 781
 782
 783
 784
 785
 786
 787
 788
 789
 790
 791
 792
 793
 794
 795
 796
 797
 798
 799
 800
 801
 802
 803
 804
 805
 806
 807
 808
 809
 810
 811
 812
 813
 814
 815
 816
 817
 818
 819
 820
 821
 822
 823
 824
 825
 826
 827
 828
 829
 830
 831
 832
 833
 834
 835
 836
 837
 838
 839
 840
 841
 842
 843
 844
 845
 846
 847
 848
 849
 850
 851
 852
 853
 854
 855
 856
 857
 858
 859
 860
 861
 862
 863
 864
 865
 866
 867
 868
 869
 870
 871
 872
 873
 874
 875
 876
 877
 878
 879
 880
 881
 882
 883
 884
 885
 886
 887
 888
 889
 890
 891
 892
 893
 894
 895
 896
 897
 898
 899
 900
 901
 902
 903
 904
 905
 906
 907
 908
 909
 910
 911
 912
 913
 914
 915
 916
 917
 918
 919
 920
 921
 922
 923
 924
 925
 926
 927
 928
 929
 930
 931
 932
 933
 934
 935
 936
 937
 938
 939
 940
 941
 942
 943
 944
 945
 946
 947
 948
 949
 950
 951
 952
 953
 954
 955
 956
 957
 958
 959
 960
 961
 962
 963
 964
 965
 966
 967
 968
 969
 970
 971
 972
 973
 974
 975
 976
 977
 978
 979
 980
 981
 982
 983
 984
 985
 986
 987
 988
 989
 990
 991
 992
 993
 994
 995
 996
 997
 998
 999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
# -*- Perl -*-
###########################################################################
# Written and maintained by Andrew Gierth <andrew@erlenstar.demon.co.uk>
# Thanks to Russ Allbery <rra@stanford.edu> for comment and significant
# contributions.
#
# Copyright 1997 Andrew Gierth. Redistribution terms at end of file.
#
# $Id: Article.pm 1.27 2002/08/11 22:51:38 andrew Exp $
#
# TODO:
#   - better way of handling the system-dependent configuration
#   - reformat source for 80 columns :-)
#
###########################################################################
#
# Envelope, n. The coffin of a document; the scabbard of a bill; the husk
#              of a remittance; the bed-gown of a love-letter.
#                                                         -- Ambrose Bierce
#

=head1 NAME

News::Article - Object for handling Usenet articles in mail or news form.

=head1 SYNOPSIS

  use News::Article;

See below for functions available.

=head1 DESCRIPTION

An object for representing a Usenet article (or a mail
message). Primarily written for use with mail2news and/or moderation
programs. (Not really intended for transit use.)

=head1 USAGE

  use News::Article;

Article exports nothing.

Article objects must be created with the I<new> method.

=cut

package News::Article;

use strict;
use SelfLoader;

use vars qw($VERSION @SENDMAIL %SPECIAL %UNIQUE);
use subs qw(canonical fix_envelope source_init);

($VERSION = (split (' ', q$Revision: 1.27 $ ))[1]) =~ s/\.(\d)$/.0$1/;

###########################################################################
# System-dependent configuration
#
# How to mail an article. The code assumes that this is a
# sendmail-workalike; i.e. can accept envelope recipients as arguments
# or -t to parse the headers for recipients. Also uses -f to set the
# envelope sender (this may cause problems on pre-V8 sendmails if
# used by an untrusted user).

@SENDMAIL = ((grep { -x $_ } 
	      qw(/usr/sbin/sendmail /usr/lib/sendmail /bin/false))[0],
	     qw(-oi -oem));

# End of system-dependent configuration
###########################################################################
# Constant data
#
# Words to treat specially when canonifying header names

%SPECIAL = map { lc $_ => $_ }
           qw(- _ ID PGP UIDL MIME NNTP SMTP IP URL HTTP WWW MimeOLE);

# RFC1036 (and news generally) is much less tolerant of multiple
# fields than RFC822. 822 allows for multiple message-ids, which is
# arguably seriously broken, so we ignore that. We list here only the
# most significant news fields; handling the rest sensibly is up to
# the caller.

%UNIQUE = map { $_ => 1 }
          qw(date followup-to from message-id newsgroups path reply-to
             subject sender);

# Description of internal storage:
#
# $self->{Headers}
#
#   A hash of header names to values. The value stored 
#   is always a reference to an array of values. The value stored
#   always includes embedded newlines and whitespace, but not the
#   header name or leading whitespace after the colon. There is no
#   trailing newline on the value.
#
# $self->{RawHeaders}
#
#   Array of headers as read from external source. One header per
#   element, with embedded newlines preserved (but trailing ones
#   removed).
#
# $self->{HeaderSeq}
#
#   Only set if headers have been read in; array of canonical header
#   names, in the order they were read in. Used to derive this from
#   RawHeaders, but that's wrong if read_headers has been called more
#   than once.
#
# $self->{Envelope}
#
#   Envelope From address. Set from a Unix-style "From " header on
#   read. When sending mail, the value here is used (unless undefined)
#   as the envelope sender.
#
# $self->{Body}
#
#   Array of text lines forming the body. Never contains embedded
#   newlines.
#
# $self->{Sendmail}
#
#   What to use to send mail.
#
# $self->{HdrsFirst}, $self->{HdrsEnd}, $self->{HdrsLast}
#
#   settings of headers_first, headers_next and headers_last
#

###########################################################################
# CONSTRUCTION
###########################################################################

=head2 Article Methods

=over 4

=item new ()

=item new ( SOURCE [,MAXSIZE [,MAXHEADS]] )

Use this to create a new Article object. Makes an empty article if no
parameters are specified, otherwise reads in an article from C<SOURCE>
as for C<read>.

=cut

sub new
{
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = { 
	Headers    => {},
	RawHeaders => [],
	Envelope   => undef,
	Sendmail   => [ @SENDMAIL ],
	Body       => [],
    };
    bless $self,$class;

    if (@_) 
    {
	return undef unless defined ($_[0]);
	$self->read(@_) or return undef; 
    }

    $self;
}

# this shouldn't be needed. But SelfLoader tries to load it in derived
# modules if it's not found here, and those modules may not have __DATA__
# tokens, leading to rude error messages.

sub DESTROY {}

SelfLoader->load_stubs();

1;

__DATA__

#--------------------------------------------------------------------------

=item clone ()

Create a new Article as an exact clone of the current one.
Returns a ref to the new object.

=cut

sub clone
{
    my $src = shift;
    my $class = ref($src);
    my $headers = {};
    my $obj = {
	Headers    => $headers,
	RawHeaders => [ @{$src->{RawHeaders}} ],
	HeaderSeq  => [ defined($src->{HeaderSeq}) ? @{$src->{HeaderSeq}} : () ],
	Envelope   => $src->{Envelope},
	Sendmail   => [ @{$src->{Sendmail}} ],
	Body       => [ @{$src->{Body}} ],
    };

    # must deep-copy the headers hash elements, otherwise they
    # get shared with rather messy results.

    for (keys %{$src->{Headers}})
    {
	$headers->{$_} = [ @{$src->{Headers}{$_}} ];
    }

    # copy default header sequence info too

    for (qw(HdrsFirst HdrsEnd HdrsLast))
    {
	$obj->{$_} = [ @{$src->{$_}} ] if defined($src->{$_});
    }

    return bless $obj,$class;
}

###########################################################################
# HEADER MANIPULATION
###########################################################################

=item envelope ( [SENDER] )

If C<SENDER> is specified, sets the envelope sender to the specified
value (which will then subsequently be used if the article is mailed).
Returns the (new or current) envelope sender in any case.

=cut

sub envelope
{
    my $self = shift;
    return $self->{Envelope} = shift if (@_);
    $self->{Envelope};
}

#--------------------------------------------------------------------------

=item rawheaders ()

Returns a list (or a reference to an array if in scalar context) of
the original header lines of the article, as read from the input
source. Terminating newlines are not included. (Continued headers are
returned as single strings with embedded newlines.)

=cut

sub rawheaders
{
    my $self = shift;
    wantarray ? @{$self->{RawHeaders}} : $self->{RawHeaders};
}

#--------------------------------------------------------------------------

=item header_names ()

Returns a list of the names of all headers currently present
in the article.

=cut

sub header_names
{
    my $self = shift;
    keys %{$self->{Headers}};
}

#--------------------------------------------------------------------------

=item headers ([FIRST [,NEXT [,LAST]]])

Returns a list of all header strings with no terminating
newlines. Continued headers will have embedded newlines.

FIRST, NEXT and LAST are optional references to arrays of header
names. The order of the returned headers is as follows:

 - headers specified by FIRST (one value only per name)
 - headers in the order originally read in (if any)
 - headers specified by NEXT (one value only per name)
 - any remaining headers not named in LAST, sorted by name
 - headers named in LAST (all values)

LAST overrides the original order of headers, but NEXT does not.
Headers named in LAST will also be grouped together by header name.

=cut

sub headers
{
    my $self = shift;
    my $hdrs = $self->{Headers};
    my @preseq = map { canonical $_ } @{shift || $self->{HdrsFirst} || []};
    my @addseq = map { canonical $_ } @{shift || $self->{HdrsEnd} || []};
    my @postseq = map { canonical $_ } @{shift || $self->{HdrsLast} || []};
    my %postseq = map { $_ => 1 } @postseq;

    # this hash gets all the headers in the form that we will use to
    # output them. Each value is an array of strings of the form
    # "Header-Name: value". The keys are in canonical rather than
    # internal form.
    my %tmph = map { my $h = canonical($_);
		     ($h, [ map { $h.": ".$_ } @{$hdrs->{$_}} ])
		     } keys %$hdrs;

    # original sequence of headers (if any) excluding those we wish
    # to force to the end.
    my @seq = grep { !$postseq{$_} } @{$self->{HeaderSeq} || []};

    # build the required list
    ((map { my $v = $tmph{$_}; $v && @$v ? shift(@$v) : (); } @preseq),
     (map { my $v = $tmph{$_}; $v && @$v ? shift(@$v) : (); } @seq),
     (map { my $v = $tmph{$_}; $v && @$v ? shift(@$v) : (); } @addseq),
     (map { my $v = $tmph{$_}; $v && @$v ? (@{$tmph{$_}}) : () }
          sort grep { !$postseq{$_} } keys %tmph),
     (map { my $v = $tmph{$_}; $v && @$v ? (@{$tmph{$_}}) : () } @postseq));
}

# the above is admittedly somewhat hairy.

#sub headers
#{
#    my $headers = $_[0]{Headers};
#    map {
#	my $header = canonical($_);
#	map { $header.": ".$_ } @{$headers->{$_}};
#    } keys %$headers;
#}

=item headers_first (HDR...)

Set default ordering for headers().

=cut

sub headers_first
{
    shift->{HdrsFirst} = [ @_ ];
}

=item headers_next (HDR...)

Set default ordering for headers().

=cut

sub headers_next
{
    shift->{HdrsEnd} = [ @_ ];
}

=item headers_last (HDR...)

Set default ordering for headers().

=cut

sub headers_last
{
    shift->{HdrsLast} = [ @_ ];
}

#--------------------------------------------------------------------------

=item set_headers ( NAME, VALUE [, NAME, VALUE [...]] )

For each header name supplied, replace any current occurences of the
header with the specified value(s). Each value may be a single scalar,
or a reference to an array of values. Returns undef without completing
the assignments if any attempt is made to supply multiple values for a
unique header. Undef or empty values cause the header to be deleted.
(If an array is supplied, it is not copied. This is probably a mistake
and should not be relied on.)

=cut

sub set_headers
{
    my $self = shift;

    while (@_)
    {
	my $name = lc shift;
	my $val = shift;

	delete $self->{Headers}{$name} and next
	    if !defined($val) || (ref($val) && @$val < 1);

	$val = [ $val ] unless ref($val);

	return undef if $UNIQUE{$name} && @$val > 1;

	$self->{Headers}{$name} = $val;
    }

    1;
}

#--------------------------------------------------------------------------

=item add_headers ( NAME, VALUE [, NAME, VALUE [...]] )

Add new header values without affecting existing ones. Each value is
either a single scalar, or a reference to an array of values. Returns
undef without completing if any attempt is made to supply duplicate
values for a unique header. (If an array reference is supplied, the
array is copied.)

=cut

sub add_headers
{
    my $self = shift;

    while (@_)
    {
	my $name = lc shift;
	my $val = shift;
	next unless defined($val);

	$val = [ $val ] unless ref($val);
	my $curval = \@{$self->{Headers}{$name}};     # magic

	return undef if ($UNIQUE{$name} && (@$val + @$curval > 1));

	push @$curval,@$val;
    }
}

# explanation of 'magic': $curval gets a reference to an array which
# is also referred to by $self->{Headers}{$name} - *even* if there was
# no previous value for $self->{Headers}{$name} (if necessary, a new
# anon array springs into existence)

#--------------------------------------------------------------------------

=item drop_headers ( NAME [, NAME [...]] )

Delete all values of the specified header(s).

=cut

sub drop_headers
{
    my $self = shift;
    for (@_)
    {
	delete $self->{Headers}{lc $_};
    }
}

#--------------------------------------------------------------------------

=item header ( NAME )

Returns a list of values for the specified header. Returns a null list
if the header does not exist. In scalar context, returns the first
value found or undef.

=cut

sub header
{
    my $self = shift;
    my $name = lc shift;
    my $val = $self->{Headers}{$name};

    return defined($val) ? @$val : () if wantarray;
    return $val->[0];
}

#--------------------------------------------------------------------------

=item rename_header ( SRC, DEST [, ACTION] )

Transform the name of a header without touching the value. Fails
if the source header does not exist. Returns undef on failure,
true on success.

Optional ACTION (may be "drop", "clobber", "add", or "fail"
(default)), specifies what to do if both source and destination exist:

  ACTION     PREVIOUS DEST
  drop       unchanged      (SRC dropped)
  clobber    dropped        (SRC replaces DEST)
  add        preserved      (SRC added to DEST)
  fail       unchanged      (operation fails)

=cut

sub rename_header
{
    my $self = shift;
    my $oldname = lc shift;
    my $newname = lc shift;
    my $action = shift || 'fail';

    return undef unless exists($self->{Headers}{$oldname});

    if (exists($self->{Headers}{$newname}))
    {
	return undef if $action eq 'fail';
    }
    else
    {
	$action = 'clobber';
    }

    my $oldval = delete $self->{Headers}{$oldname};

    if    ($action eq 'clobber') { $self->{Headers}{$newname} = $oldval; }
    elsif ($action eq 'add')     { $self->add_headers($newname, $oldval); }

    1;
}

###########################################################################
# ARTICLE BODY
###########################################################################

=item body ()

Return the body of the article as a list of lines (no newlines),
or a reference to an array in scalar context (the array may be
modified in this case).

=cut

sub body
{
    wantarray ? @{$_[0]->{Body}} : $_[0]->{Body};
}

#--------------------------------------------------------------------------

=item lines ()

Returns the number of lines in the article body.

=cut

sub lines
{
    my $self = shift;
    scalar(@{$self->{Body}});
}

#--------------------------------------------------------------------------

=item bytes ()

Returns the total size of the article body, not counting newlines.

=cut

sub bytes
{
    my $self = shift;
    my $total = 0;
    for (@{$self->{Body}})
    {
	$total += length($_);
    }
    $total;
}

#--------------------------------------------------------------------------

=item set_body ( BODY )

Replace the current article body with the specified text.  Expects a
list, each item of which is either one line, or multiple lines
separated by newlines. (Trailing newlines on the values are ignored.)

=cut

sub set_body
{
    my $self = shift;
    $self->{Body} = [];
    $self->add_body(@_);
}

#--------------------------------------------------------------------------

=item add_body ( BODY )

Append the specified text to the current article body.  Expects a
list, each item of which is either one line, or multiple lines
separated by newlines, or a reference to an array of lines. (Trailing
newlines on the values are ignored.)

=cut

sub add_body
{
    my $self = shift;
    my $body = $self->{Body};

    for (@_)
    {
	if (ref($_))
	{
	    $self->add_body(@$_);
	}
	else 
	{
	    my @lines = split(/\n/);
	    push @$body,@lines ? @lines : "";
	}
    }
}

#--------------------------------------------------------------------------

=item trim_blank_lines ()

Remove any trailing blank lines from the article body. Returns the
number of lines removed.

=cut

sub trim_blank_lines
{
    my $body = shift->{Body};
    my $n = 0;
    while (@$body && $body->[$#$body] =~ /^\s*$/) { pop @$body; ++$n; }
    return $n;
}

###########################################################################
# INPUT FUNCTIONS
###########################################################################

=item read_headers ( SOURCE, MAXSIZE )

Read article headers (terminated by an empty line) from the specified
source (see C<read> for defintion of allowed sources).

Gives up (returning undef) if more than MAXSIZE bytes are read. Returns
the amount read.

=cut

sub read_headers
{
    my ($self, $source, $maxsz) = @_;
    my $last = undef;
    my $first = 1;
    my $hhead = {};
    my $name;
    my $val;
    my $size = 0;

    # Nuke the body and hashed headers - always.

    $self->{Body} = [];
    $self->{Headers} = $hhead;

    my $hseq = $self->{HeaderSeq} = [];

    # If we have read some raw headers already, append a marker.  This
    # is partly to cope with C-news/ANU-news moderator mail, where the
    # news article is encapsulated in a mail message rather than
    # simply mailed, but we don't want to lose the mail path.

    my $head = $self->{RawHeaders};
    push @$head,"X-More-Headers: ----" if @$head;

    # Set up the data source.

    $source = source_init($source);
    return undef unless defined($source);

    my $line;

    while (defined($line = &$source()))
    {
	# size limit

	return undef if ($size += length($line)) > $maxsz;

	chomp $line;
	last if $line eq '';

	for (split(/\n/,$line))
	{
	    # lines of whitespace only are allowed in continuations - but
	    # we drop them as they serve no useful purpose
	    # XXX - what about signatures? not an issue for pgpmoose or
	    #       signcontrol, neither of which allow continuations in
	    #       signed headers at all, but could become an issue in the
	    #       future - in which case this behaviour would have to be
	    #       removed
	    next if /^\s*$/;

	    # Envelope From (unix-style). Must be the first line, and we trim
	    # off the timestamp if present

	    if (!$last && /^From (.*)$/)
	    {
		$self->{Envelope} = fix_envelope($1);
		next;
	    }

	    # Ignore bogus extra >From lines (procmail has a bad habit of adding
	    # these, unpredictably, unless you recompile it to trust everybody)
	    next if /^>From /;

	    # continuation line? If so, append to most recent data
	    if (/^\s/)
	    {
		if (ref($last))
		{
		    $head->[$#$head] .= "\n".$_;
		    $last->[$#$last] .= "\n".$_;
		}
		next;
	    }

	    # Extract header name and value. If the name looks
	    # unreasonable, hack around it to make the problem easily
	    # visible. We are deliberately over-strict in the allowed
	    # format of names (the RFCs allow any printable ASCII char
	    # other than whitespace or ':' in header names, but in
	    # practice only alphanumerics, '-' and (rarely) '_' are
	    # found). We lose any superfluous whitespace after the ':'
	    # here (only likely to be noticable for Subject lines).
	    
	    if (/^([\w-]+):\s+(.*)$/)
	    {
		$val = $2;
		$name = lc $1;
	    }
	    else
	    {
		$val = $_;
		$name = "x-broken-header";
	    }
	    
	    # Tack raw header onto array of raw headers

	    push @$hseq,canonical($name);
	    push @$head,$_;
	    
	    # Add header to hash. Roughly equivalent to add_header, but
	    # handles duplicate unique headers silently

	    $last = \@{$hhead->{$name}};
	    push @$last,$val unless $UNIQUE{$name} && @$last;
	}
    }

    $size;
}   

#--------------------------------------------------------------------------

=item read_body ( SOURCE, MAXSIZE )

Read an article body from the specified source (see C<read>). Stops at
end of file; fails (returning undef) if MAXSIZE is reached prior to
that point.  Returns the number of bytes read (may be 0 if the body is
null).

Trailing blank lines are NOT removed (an incompatible, but regrettably
necessary, change from previous versions); see trim_blank_lines if you
need to do that.

=cut
	
sub read_body
{
    my ($self, $source, $maxsize) = @_;
    my $size = 0;

    # Set up the data source.

    $source = source_init($source);
    return undef unless defined($source);

    my $body = $self->{Body} = [];
    my $line;

    while (defined($line = &$source()))
    {
	return undef if ($size += length($line)) > $maxsize;
	chomp $line;
	push @$body,"" unless $line;

	for (split(/\n/,$line,-1))
	{
	    push @$body,$_;
	}
    }

    # return the article size
    $size;
}

#--------------------------------------------------------------------------

=item read ( SOURCE [,MAXSIZE [,MAXHEADS]] )

Reads in an article from C<SOURCE>.

C<SOURCE> may be any of the following:

- a CODE ref, which is called to return lines or chunks of data

- an ARRAY ref, assumed to contain a list of lines with optional
line terminators

- a SCALAR ref, assumed to contain text with embedded newlines

- a scalar, assumed to be a filename, which is opened and read

- anything else is assumed to be a glob, reference to a glob,
or reference to a filehandle, and is read from accordingly

When reading in articles, C<MAXHEADS> is the maximum header size to
read (default 8k), and C<MAXSIZE> is the maximum article body size
(default 256k). If C<MAXSIZE> is explicitly specified as 0, then no
attempt at reading the body is made. Returns the total number of bytes
read, or undef if either limit is reached or no headers were found.

=cut

sub read
{
    my ($self, $source, $maxsize, $maxhead) = @_;
    my $hsize = 0;
    my $bsize = 0;

    $maxhead = 8192 unless $maxhead;
    $maxsize = 262144 unless defined($maxsize);

    # Set up the data source.

    $source = source_init($source);
    return undef unless defined($source);

    $hsize = $self->read_headers($source,$maxhead)
	or return undef;

    if ($maxsize)
    {
	$bsize = $self->read_body($source,$maxsize);
	return undef unless defined($bsize);
    }

    $hsize + $bsize;
}

###########################################################################
# OUTPUT FUNCTIONS
###########################################################################

=item write ( FILE )

Write the entire article to the specified filehandle reference.

=cut

sub write
{
    my ($self, $fh) = @_;
    print $fh join("\n", $self->headers(), "", @{$self->{Body}}, "");
}

=item write_unique_file ( DIR [,MODE] )

Write the article to a (hopefully) uniquely-named file in the
specified directory.  The file is written under a temporary name (with
a leading period) and relinked when complete. Returns 1 if successful,
otherwise undef.

MODE is the access mode to use for the created file (default 644);
this will be modified in turn by the current umask.

The implementation is careful to avoid losing the file or clobbering
existing files even in the case of a name collision, but relies on
POSIX link() semantics and may fail on lesser operating systems
(or buggy NFS implementations).

=cut

sub write_unique_file;

use POSIX qw(:errno_h);
use Fcntl;
use FileHandle ();

; sub write_unique_file
{
    my ($self, $dir, $mode) = @_;

    return undef unless defined($dir) and length($dir);
    $mode = 0644 unless defined($mode);

    my ($name,$tname,$fh);

    do 
    {
	$tname = $name = $self->_unique_name();
	$tname =~ s/^././;
	$fh = FileHandle->new("$dir/$tname", O_CREAT|O_EXCL|O_WRONLY, $mode);
    } 
    while (!$fh && $! == &EEXIST);
    return undef unless $fh;

    my $success;

    if ($self->write($fh) && $fh->close())
    {
	while (!link("$dir/$tname","$dir/$name") && $! == &EEXIST)
	{
	    $name = $self->_unique_name();
	}
	$success = 1;
    }

    unlink("$dir/$tname");
    return $success;
}

#--------------------------------------------------------------------------

=item write_original ( FILE )

Write the original headers followed by the article body to the
specified filehandle reference.

=cut

sub write_original
{
    my ($self, $fh) = @_;
    print $fh join("\n", @{$self->{RawHeaders}}, "", @{$self->{Body}}, "");
}

###########################################################################
# MAIL FUNCTIONS
###########################################################################

=item sendmail ( [COMMAND] )

Get or set the command and options that will be used to mail the
article. Defaults to a system dependent value such as
  /usr/sbin/sendmail -oi -oem

=cut

sub sendmail
{
    my $self = shift;
    $self->{Sendmail} = [ @_ ] if (@_);
    @{$self->{Sendmail}};
}

#--------------------------------------------------------------------------

=item mail ( [RECIPIENTS...] )

Mails the article to the specified list of recipients, or to the
addressed recipients in the header (To, Cc, Bcc) if none are supplied.
Attempts to set the envelope sender to the stored envelope sender, if
set, so unset that before mailing if you do not want this behavior.

=cut

sub mail;

use FileHandle ();
use IPC::Open3 qw(open3);

; sub mail 
{
    my ($self, @recipients) = @_;
    my @command = @{$self->{Sendmail}};
    push @command,'-f',$self->{Envelope} if (defined($self->{Envelope}));
    push @command, @recipients ? @recipients : '-t';

    my $sendmail = FileHandle->new();
    my $errors = FileHandle->new();

    eval { open3 ($sendmail, $errors, $errors, @command) };
    if ($@) { return undef }

    local $SIG{PIPE} = 'IGNORE';

    $self->write($sendmail);
    close $sendmail;

    # Check the return status of sendmail to see if we were successful.
    $? == 0;
}

###########################################################################
# NEWS FUNCTIONS
###########################################################################

=item post ( [CONN] )

Post the article. Avoids inews due to undesirable header munging and
unwarranted complaints to stderr. Takes an optional parameter which is
a Net::NNTP reference.  If supplied, posts the article to it;
otherwise opens a new reader connection and posts to that.

Throws an exception containing the error message on failure.

=cut

sub post;

use Net::NNTP ();

; sub post
{
    my $self = shift;
    my $server = shift;

    if (!$server)
    {
	$server = Net::NNTP->new();
	die "Unable to connect to server" unless $server;
	$server->reader();
    }

    $server->post(join("\n", $self->headers(), "", @{$self->{Body}}))
	or die $server->code().' '.($server->message())[-1];

    1;
}

=item ihave ( [CONN] )

Inject the article. Takes an optional parameter which is a Net::NNTP
reference.  If supplied, posts the article to it; otherwise opens a
new transport connection and posts to that. All required headers must
already be present, including Path and Message-ID.

Throws an exception containing the error message on failure.

=cut

sub ihave;

use Net::NNTP ();

; sub ihave
{
    my $self = shift;
    my $server = shift;

    my $msgid = $self->header('message-id');
    die "Article contains no message-id" unless $msgid;

    if (!$server)
    {
	$server = Net::NNTP->new();
	die "Unable to connect to server" unless $server;
    }

    $server->ihave($msgid, join("\n", $self->headers(), "", @{$self->{Body}}))
	or die $server->code().' '.($server->message())[-1];

    1;
}

#--------------------------------------------------------------------------

=item add_message_id ( [PREFIX [, DOMAIN] ] )

If the current article lacks a message-id, then create one.

=cut

sub add_message_id;

use Net::Domain qw(hostfqdn);

; sub add_message_id
{
    my $self = shift;
    return undef if $self->{Headers}{'message-id'};

    my $prefix = shift || '';
    my $domain = shift || hostfqdn() || 'broken-configuration';
    my ($sec,$min,$hr,$mday,$mon,$year) = gmtime(time);
    ++$mon;
    $self->set_headers('message-id', 
		       sprintf('<%s%04d%02d%02d%02d%02d%02d$%04x@%s>',
			       $prefix, 
			       $year+1900, $mon, $mday, $hr, $min, $sec,
			       0xFFFF & (rand(32768) ^ $$), $domain));
}

#--------------------------------------------------------------------------

=item add_date ( [TIME] )

If the current article lacks a date, then add one (in local time).
If TIME is specified (numerical Unix time), it is used instead of the
current time.

=cut

sub add_date
{
    my $self = shift;
    return undef if $self->{Headers}{'date'};

    my $now = shift || time;
    my ($sec,$min,$hr,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($now);
    my ($gsec,$gmin,$ghr,$gmday) = gmtime($now);

    # mystic incantations to calculate zone offset from difference
    # between UTC and local time. Assumes that difference is not more
    # than a full day (saves having to take months into consideration).
    # ANSI is apparently going to add a spec to strftime() to do this,
    # but that isn't yet commonly available.

    use integer;
    $gmday = $mday + ($mday <=> $gmday) if (abs($mday-$gmday) > 1);
    my $tzdiff = 24*60*($mday-$gmday) + 60*($hr-$ghr) + ($min-$gmin);
    my $tz = sprintf("%+04.4d", $tzdiff + ($tzdiff/60*40));

    $mon = (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$mon];
    $wday = (qw(Sun Mon Tue Wed Thu Fri Sat Sun))[$wday];
    $year += 1900;
    $self->set_headers('date',
		       sprintf("%s, %02d %s %d %02d:%02d:%02d %s",
			       $wday,$mday,$mon,$year,$hr,$min,$sec,$tz));
}
   

###########################################################################
# AUTHENTICATION FUNCTIONS
###########################################################################

# Internal function used by PGPMoose sign/verify code

sub pgpmoose_canon_headers
{
    my ($self, $bug_compatible) = @_;

    # Now, put together all of the stuff we need to sign.  First, we need a
    # list of newsgroups, sorted.

    my $headers = $self->header('newsgroups');
    $headers =~ s/\s//g;
    $headers = join("\n", (sort split(/,+/, $headers)), '');

    # Next we need an array of headers: From, Subject, and Message-ID in
    # that order, killing initial and final whitespace and any spaces after
    # colons.
    # PGPMoose V1.1 has a gross bug: it includes, as though they were headers,
    # any body lines that look like headers. Do this only if $bug_compatible

    my %heads = map { ($_, [ $self->header($_) ]) } qw(from subject message-id);

    if ($bug_compatible)
    {
	for (@{$self->{Body}})
	{
	    /^from: *(.*)$/i && push @{$heads{from}},$1;
	    /^subject: *(.*)$/i && push @{$heads{subject}},$1;
	    /^message-id: *(.*)$/i && push @{$heads{'message-id'}},$1;
	}
    }

    for (@heads{'from','subject','message-id'})
    {
	for (@$_)
	{
	    s/\n.*//;
	    s/^ +//;
	    s/\s*$/\n/;
	    s/: +/:/g;
	    $headers .= $_;
	}
    }

    $headers;
}

=item sign_pgpmoose ( GROUP, PASSPHRASE [, KEYID] )

Signs the article according to the PGPMoose spec.  We require that pgp be
on the path to do this.  Takes a "group" which can be either a newsgroup
or an address, a PGP password, and an optional key id and returns a null
list on success, the PGP error output as a list on failure.

If the key id is omitted, we will assume that if the group is an e-mail
address, the key id is that address surrounded by <>, and otherwise the
key id will be the group with a space on either side.  This is so that one
can help PGP distinguish between the keys for (say) mod.config and
mod.config.status.  The PGP key id should be something like:

  Moderator of group.name <request-address@some.host>

The article to be signed must already have all of the headers needed by
PGPMoose (Newsgroups, From, Subject) or this will fail. Message-ID is
added if necessary.

=cut

sub sign_pgpmoose;

use PGP::Sign qw(pgp_sign pgp_verify pgp_error);

; sub sign_pgpmoose 
{
    my ($self, $group, $passphrase, $keyid) = @_;

    # If we don't have a key id, try to generate one from the group.
    # Surround it by angle brackets if it's an e-mail address or by spaces
    # if it's a group.

    $keyid = ($group =~ /\@/) ? "<$group>" : " $group "
	unless (defined $keyid);

    # Check to make sure we have the required headers.
    for (qw(newsgroups from subject)) 
    {
        return ("Required header $_ missing")
	    unless $self->{Headers}{$_};
    }

    $self->add_message_id() unless $self->{Headers}{'message-id'};

    # Now, put together all of the stuff we need to sign.
    # XXX generate V1.1 bug-compatible version for now.

    my $headers = $self->pgpmoose_canon_headers(1);

    # Finally, we need to give it the body of the article, making the
    # following transformations:
    #
    #  - Lines consisting solely of spaces are deleted.
    #  - A leading "--" is replaced by "- --"
    #  - A leading "from" (case-insensitive) has > prepended.
    #  - A leading "subject" (case-insensitive) has > prepended.
    #  - A leading single "." is changed to "..".
    #  - All trailing whitespace on a line is removed.
    #
    # The easy way to do this is to define an anonymous sub that sends back
    # a line at a time.  That way, we don't end up wasting memory by storing
    # two copies of the article body (which could potentially be long).
    my $body;
    {
        my $line = 0;
        $body = sub {
            my $text;
            do 
	    {
                $text = $self->{Body}[$line++];
                return undef unless defined $text;
            } while ($text =~ /^ *$/);
            $text =~ s/^--/- --/;
            $text =~ s/^(from|subject)/>$1/i;
            $text =~ s/^\.($|[^.])/..$1/;
            $text =~ s/\s+$//;
            $text . "\n";
        }
    }

    # Now, actually calculate the signature and add it to the headers.
    my $signature = pgp_sign ($keyid, $passphrase, $headers, $body);
    return pgp_error
	unless defined($signature);

    $signature =~ s/\n(.)/\n\t$1/g;
    $self->add_headers('x-auth', "PGPMoose V1.1 PGP $group\n\t$signature");
    return ();
}

#--------------------------------------------------------------------------

=item verify_pgpmoose ( GROUP )

Verifies an article signature according to the PGPMoose spec.  We
require that pgp be on the path to do this.  Takes a "group" which can
be either a newsgroup or an address, and an optional key id.

Looks for a X-Auth header matching the specified group or address, and
if found, checks the validity of the signature. If successful, returns
the signer identity (from the PGP output), otherwise returns false.

=cut

sub verify_pgpmoose;

use PGP::Sign qw(pgp_sign pgp_verify pgp_error);

; sub verify_pgpmoose 
{
    my ($self, $group, $keyid) = @_;

    my $sig = (grep(/^ PGPMoose \s+ V\d\.\d \s+ PGP \s+ \Q$group\E \n /isx,
		      $self->header('x-auth')))[0];

    return undef unless $sig;

    my ($ver) = $sig =~ /^ PGPMoose \s+ V(\d\.\d) \s+/isx;

    $sig =~ s/[^\n]*\n//;
    $sig =~ s/\t//g;

    # Now, put together all of the stuff we need to sign.
    # XXX Optimistically, assume that pmcanon will be fixed after 1.1.

    my $headers = $self->pgpmoose_canon_headers($ver eq '1.1');

    # Finally, we need to give it the body of the article, making the
    # following transformations:
    #
    #  - Lines consisting solely of spaces are deleted.
    #  - A leading "--" is replaced by "- --"
    #  - A leading "from" (case-insensitive) has > prepended.
    #  - A leading "subject" (case-insensitive) has > prepended.
    #  - A leading single "." is changed to "..".
    #  - All trailing whitespace on a line is removed.
    #
    # The easy way to do this is to define an anonymous sub that sends back
    # a line at a time.  That way, we don't end up wasting memory by storing
    # two copies of the article body (which could potentially be long).
    my $body;
    {
        my $line = 0;
        $body = sub {
            my $text;
            do 
	    {
                $text = $self->{Body}[$line++];
                return undef unless defined $text;
            } while ($text =~ /^ *$/);
            $text =~ s/^--/- --/;
            $text =~ s/^(from|subject)/>$1/i;
            $text =~ s/^\.($|[^.])/..$1/;
            $text =~ s/\s+$//;
            $text . "\n";
        }
    }

    pgp_verify ($sig, undef, $headers, $body);
}

#--------------------------------------------------------------------------

=item sign_control ( KEYID, PASSPHRASE [, HEADER [...] ] )

Signs the article in the manner used for control messages.  This is
derived from signcontrol, written by David Lawrence, but with fewer sanity
checks since we assume people know what they're doing.  Caveat programmer.

We take a key id, a PGP password, and an optional list of extra
headers to add to the signature.  By default, Subject, Control,
Message-ID, Date, From, and Sender are signed. Any signed header that
isn't present in the article will be signed with an empty value. Date
and Message-ID are automatically added if needed.

=cut

sub sign_control;

use PGP::Sign qw(pgp_sign pgp_verify pgp_error);

; sub sign_control 
{
    my ($self, $keyid, $passphrase, @extra) = @_;
    my @headers = qw(subject control message-id date from sender);
    push @headers, map {lc $_} @extra;

    # Check to make sure we have the required headers.
    for (qw(subject control from))
    {
        return ("Required header $_ missing")
	    unless $self->{Headers}{$_};
    }

    $self->add_message_id('cmsg-') unless $self->{Headers}{'message-id'};
    $self->add_date();

    # We have to sign the list of headers and each header on a seperate
    # line.  Note that the verification code doesn't support continuation
    # headers, so be careful not to use them when calling this method.

    my $signheads = join (',', map { canonical $_ } @headers);
    my @sign;
    push (@sign, 'X-Signed-Headers: ' . $signheads . "\n");
    for (@headers) 
    {
        push (@sign, (canonical $_).": ".($self->header($_) || '')."\n");
    }

    # Now send everything to PGP to sign.  We have to add a new line to the
    # end of every line of the body, since we're storing it without them.
    # Make sure we munge for attached signatures, since pgpverify tests with
    # an attached signature.
    local $PGP::Sign::MUNGE = 1;
    my $body;
    {
        my $line = 0;
        $body = sub {
            my $text = $self->{Body}[$line++];
            defined $text ? $text . "\n" : undef;
        }
    }
    my ($signature, $version) =
        pgp_sign ($keyid, $passphrase, \@sign, "\n", $body);
    return pgp_error
	unless defined($signature);

    # Add tabs after the newlines and add the signature to the headers.
    $signature =~ s/\n(.)/\n\t$1/g;

    # Fix up version field (needed for at least PGP 6.5.1i)
    $version =~ s/^[PGpg]+\s+//;   # remove initial PGP or GPG or whatever
    $version =~ s/\s+/_/g;         # convert any remaining whitespace

    $self->add_headers('x-pgp-sig', "$version $signheads\n\t$signature");
    return ();
}

###########################################################################
# INTERNAL METHODS
###########################################################################

# Unique name generator for write_unique_file. This is called as a method
# to allow it to be overridden (should anyone want to). The implementation
# specifically takes account of the possibility of multiple calls in quick
# succession from the same process (and possibly different objects, which
# is why $unique_count is not an instance variable).

sub _unique_name;

my $unique_count = "aa";

; sub _unique_name
{
    my $name = sprintf("%08x%04x%2s",
		       time & 0xffffffff,
		       $$ & 0xffff,
		       $unique_count);
    $unique_count = "aa" if (length(++$unique_count) > 2);
    return $name;
}

###########################################################################
# INTERNAL FUNCTIONS
###########################################################################

# really ought to convert some of these to methods.

# Convert a header name to canonical capitalisation. We keep the header
# names in lowercase internally to simplify, but prefer to emit standard-
# looking forms on output.

sub canonical
{
    my $name = lc shift;
    join('',map { ($SPECIAL{$_} || ucfirst $_); } split(/([_-])/,$name));
}

# Fix up an envelope sender taken from a Unix-style "From" line.

# This isn't guaranteed to work due to variations in From line
# format. An explicit decision has been made to trust the
# header format *rather than* the sanity of the envelope
# address, because we have no control over the latter, whereas
# the former is generated by local software and therefore
# should be fixable if it is too insane.

# Theory:
#   If there's a timestamp (check for MMM DDD NN HH:MM) then remove
#   it and everything following it. Otherwise remove any trailing
#   text resembling 'remote from ...'.
#   Then remove trailing spaces from the result and return it.

sub fix_envelope
{
    my $from = shift;

    $from =~ s/\s \w\w\w \s \w\w\w \s [\d\s]\d \s \d\d:\d\d(:\d\d)? \s .*? $//x
	or $from =~ s/\s remote \s from \s .* $//x;

    $from =~ s/\s+$//;

    return $from;
}

# Initialise a data source; returns a CODE ref with which to
# read from that source.
#
# Allowed sources are:
#  GLOBs or unknown refs are assumed to be filehandles or equivalent.
#  ARRAY refs (treated as a list of lines)
#  SCALAR refs (treated as text)
#  SCALARs (treated as filenames)
#  CODE refs are left unchanged

sub source_init_filehandle;

use FileHandle ();

; sub source_init_filehandle
{
    return FileHandle->new(shift);
}

sub source_init
{
    my $source = shift;

    if (ref(\$source) ne 'GLOB')
    {
	return $source if (ref($source) eq 'CODE');
    
	if (ref($source) eq 'ARRAY')
	{
	    my $index = 0;
	    return sub { $source->[$index++] };
	}

	if (ref($source) eq 'SCALAR')
	{
	    my $pos = 0;
	    return sub { return undef unless $pos < length($$source);
			 my $tmp = $pos;
			 $pos = 1 + index($$source,"\n",$tmp);
			 if ($pos <= $tmp)
			 {
			     $pos = 1 + length($$source);
			     return substr($$source,$tmp);
			 }
			 else
			 {
			     return substr($$source,$tmp,($pos - $tmp));
			 }
		     };
	}
    
	if (!ref($source))
	{
	    $source = source_init_filehandle("<$source");
	    return undef unless $source;
	}
    }

    return sub { scalar(<$source>) };
}

###########################################################################
# THE END
###########################################################################

1;

__END__

###########################################################################

=back

=head1 CAVEATS

This module is not fully transparent. In particular:

=over 4

=item -

Case of headers is smashed

=item -

improper duplicate headers may be discarded

=item -

Broken or dubious header names are not preserved

=back

These factors make it undesirable to use this module in news transit
applications.

=head1 AUTHOR

Written by Andrew Gierth <andrew@erlenstar.demon.co.uk>

Thanks to Russ Allbery <rra@stanford.edu> for comments and
suggestions.

=head1 COPYRIGHT

Copyright 1997-2002 Andrew Gierth <andrew@erlenstar.demon.co.uk>

This code may be used and/or distributed under the same terms as Perl
itself.

=cut

###########################################################################
#
# Random Comments
#
# Consistency: I'd like to drop the use of FileHandle in favour of the
# IO::* modules, but I don't want to completely break with 5.003 at this
# stage (though I no longer test with 5.003, so there is no guarantee that
# it works at all).
#
# Use of $_; at present, I'm confining it to for() and map{} / grep{}
# constructs (where it is implicitly localised).
#
# SelfLoader: the use of funky indenting to do deferred 'use' statements
# and other compile-time stuff seems to me to be over-kludgy. It's merely
# an artifact of SelfLoader's fairly simplistic method of locating the
# start and end of each function.
#
# Net::Domain seems to do poorly on BSD systems without permanent 
# connectivity (hangs in domainname() doing unnecessary DNS lookups).
# Must take that up with the maintainer at some stage if it hasn't 
# already been fixed.
#
# indirect-object vs. method call syntax for ctors: I still can't decide
# which I prefer. I've removed all the IO ones for now.
#
#

###########################################################################
#
# $Log: Article.pm $
# Revision 1.27  2002/08/11 22:51:38  andrew
# no changes, other than copyright date, this is just to bumb the version no.
#
# Revision 1.26  2001/11/08 14:11:43  andrew
# remove stray spaces from unique filenames
#
# Revision 1.25  2001/04/20 12:11:31  andrew
# handle PGP versions that put spaces in the version field, in sign_control
#
# Revision 1.24  2001/01/18 09:48:44  andrew
# work around a SelfLoader issue.
# Allow $obj->new() to work as well as CLASS->new()
#
# Revision 1.23  2000/04/14 15:11:49  andrew
# handle newlines in body better
#
# Revision 1.22  2000/04/02 12:02:27  andrew
# add parameter to add_date
#
# Revision 1.21  1998/10/21 03:15:31  andrew
# Doc tweaks and minor cleanup.
# Improvements to write_unique_file to handle collisions.
#
# Revision 1.20  1998/10/18 06:01:00  andrew
# Speedup to source_init when FileHandle is not required
#
# Revision 1.19  1998/10/18 05:41:32  andrew
# Added write_unique_file
#
# Revision 1.18  1998/10/18 03:42:19  andrew
# read_body no longer strips blank lines.
# trim_blank_lines added to compensate.
# Added IP, HTTP and URL to list of abbreviations used in canonical
# headers.
# Original sequence of headers is handled slightly differently.
#
# Revision 1.17  1998/07/05 18:03:05  andrew
# Fix the PGPMoose bug-compatible code to handle tabs the same
# way as the reference code
#
# Revision 1.16  1998/07/05 08:40:18  andrew
# Bugfix to read(SCALAR) not to drop characters.
#
# Rehash the PGPMoose code to correctly emulate the disgusting bug in
# PGPMoose V1.1 which treats body lines as though they were headers.
#
# Revision 1.15  1998/02/26 00:50:46  andrew
# Cleanup:
#   - remove "use English"
#   - use Selfloader to cut startup time
#   - minor mods (in sign_control and sign_pgpmoose) to avoid pulling
#     in selfloaded sub add_message_id unless needed
#   - change read_header to keep first copy of duplicate unique header,
#     rather than last copy
#
# Revision 1.14  1997/12/29 14:35:26  andrew
# Fixed order-reverse problem in headers() (oops)
#
# Revision 1.13  1997/12/27 23:19:07  andrew
# Missing 'x' flag on extended regexp in fix_envelope
#
# Revision 1.12  1997/12/13 13:00:52  andrew
# Changed add_date to use local time and add timezone offset
#
# Revision 1.11  1997/12/12 11:42:34  andrew
# corrections to header ordering code
#
# Revision 1.10  1997/12/12 11:09:30  andrew
# Added header ordering stuff
#
# Revision 1.9  1997/12/10 19:20:54  andrew
# added ihave
#
# Revision 1.8  1997/11/08 17:51:45  andrew
# Typos, and handling of error return in post().
#
# Revision 1.7  1997/10/22 20:59:27  andrew
# Clean up distribution terms for release
#
# Revision 1.6  1997/10/22 19:54:41  andrew
# Fixed old typo in RCS revision keyword
#
# Revision 1.5  1997/08/31 01:35:25  andrew
# Added obligatory quotation :-)
#
# Revision 1.4  1997/08/29 03:31:07  andrew
# Fix typo in previous mod
#
# Revision 1.3  1997/08/29 00:34:28  andrew
# Update for latest PGP::Sign (v0.08).
# Add reference handling to add_body().
# Allow -f '' in mail().
#
# Revision 1.2  1997/07/30 12:13:11  andrew
# cleanup (no changes)
#
# Revision 1.1  1997/07/29 15:20:40  andrew
# Initial revision
#
#
#
###########################################################################