`emailrelay-set-from.pl <emailrelay-set-from.pl>`_
--------------------------------------------------

.. code:: perl

    #!/usr/bin/env perl
    #
    # SPDX-FileCopyrightText: 2026 Graeme Walker <graeme_walker@users.sourceforge.net>
    # SPDX-License-Identifier: FSFAP
    # 
    # Copyright (c) 2026 Graeme Walker <graeme_walker@users.sourceforge.net>
    # 
    # Copying and distribution of this file, with or without modification,
    # are permitted in any medium without royalty provided the copyright
    # notice and this notice are preserved.  This file is offered as-is,
    # without any warranty.
    # ===
    #
    # emailrelay-set-from.pl
    #
    # An example E-MailRelay filter script that edits the
    # content originator headers (ie. From, Sender and Reply-To)
    # in the content file to a fixed value.
    #
    # This does not set the envelope-from field in the envelope
    # file by default. If the remote server expects the SMTP
    # MAIL-FROM address to match the "From:" header then set
    # $edit_envelope to 1.
    #
    # See also: emailrelay-set-from.js, RFC-2822
    #
    
    use strict ;
    use IO::File ;
    $SIG{__DIE__} = sub { (my $e = join(" ",@_)) =~ s/\n/ /g ; print "<<error: $e>>\n" ; exit 99 } ;
    
    my $edit_envelope = 0 ; # <= set to 1 to also update the envelope-from address
    
    # originator fields (RFC-2822 3.6.2)
    my $new_from = 'noreply@example.com' ; # <= edit this
    my $new_sender = '' ;
    my $new_reply_to = $new_from ;
    
    my $content = $ARGV[0] or die "usage error\n" ;
    my $envelope = $ARGV[1] or die "usage error\n" ;
    
    my $in = new IO::File( $content , "r" ) or die ;
    my $out = new IO::File( "$content.tmp" , "w" ) or die ;
    my $in_body = undef ;
    my $in_edit = undef ;
    while(<$in>)
    {
    	if( $in_body )
    	{
    		print $out $_ ;
    	}
    	else
    	{
    		chomp( my $line = $_ ) ;
    		$line =~ s/\r$// ;
    
    		$in_body = 1 if ( $line eq "" ) ;
    		my $is_from = ( $line =~ m/^From:/i ) ;
    		my $is_sender = ( $line =~ m/^Sender:/i ) ;
    		my $is_reply_to = ( $line =~ m/^Reply-To:/i ) ;
    
    		if( $in_body )
    		{
    			print $out "\r\n" ;
    		}
    		elsif( $is_from && defined($new_from) )
    		{
    			$in_edit = 1 ;
    			print $out "From: $new_from\r\n" ;
    		}
    		elsif( $is_sender && defined($new_sender) )
    		{
    			$in_edit = 1 ;
    			print $out "Sender: $new_sender\r\n" unless $new_sender eq "" ;
    		}
    		elsif( $is_reply_to && defined($new_reply_to) )
    		{
    			$in_edit = 1 ;
    			print $out "Reply-To: $new_reply_to\r\n" ;
    		}
    		elsif( $in_edit && $line =~ m/^[ \t]/ ) # original header was folded
    		{
    		}
    		else
    		{
    			$in_edit = undef ;
    			print $out $line , "\r\n" ;
    		}
    	}
    }
    $out->close() or die ;
    rename( "$content.tmp" , $content ) or die ;
    
    if( $edit_envelope )
    {
    	my $etext ;
    	{
    		my $fh = new IO::File( $envelope , "r" ) or die "cannot read envelope file [$envelope]" ;
    		local $/ = undef ;
    		$etext = <$fh> ;
    	}
    	( $etext =~ m/X-MailRelay-/ ) or die ;
    	$etext =~ s/X-MailRelay-From:.*/X-MailRelay-From: $new_from\r/m ;
    	{
    		my $fh = new IO::File( $envelope , "w" ) or die "cannot write envelope file [$envelope]" ;
    		print $fh $etext ;
    		$fh->close() or die ;
    	}
    }
    
    exit 0 ;

.. _../examples/emailrelay-set-from.pl: emailrelay-set-from_pl.html