|
|
#include "SendSlot.h"
//#include "crtdbg.h"
//-----------------------------------------------------------------------------
CMailSlot::CMailSlot()
: hMailSlot(0)
{
}
//-----------------------------------------------------------------------------
CMailSlot::~CMailSlot()
{
if (hMailSlot)
{
CloseHandle(hMailSlot);
hMailSlot = 0;
}
}
|
|
|
#pragma once
#include <windows.h>
#include <tchar.h>
//#define _T(s) s
const TCHAR SLOT_NAME[] = _T("\\w32chat_mfc1_0");
const int IN_MSG_SIZE = 5000;
const int OUT_MSG_SIZE = 5000;
const int SLOT_PATH_SIZE = 256;
//-----------------------------------------------------------------------------
class CMailSlot
{
public:
CMailSlot();
~CMailSlot();
protected:
DWORD iErrorState;
HANDLE hMailSlot;
TCHAR szSlotPath[SLOT_PATH_SIZE];
};
|
|
|
#include "MainWindow.h"
#include "SendSlot.h"
#include "RecvSlot.h"
#include "resource.h"
#include "UBUServer.h"
#include "tchar.h"
const int INPUT_LIMIT = 512; // Maximum no of chars entered into input CEdit
const int VISIBLE_LINES = 14; // Visible lines in the display CEdit.
#include "crtdbg.h"
#ifdef _DEBUG
#define MYDEBUG_NEW new(_NORMAL_BLOCK, __FILE__, __LINE__)
#define new MYDEBUG_NEW
#else
#define MYDEBUG_NEW
#endif // _DEBUG
BEGIN_MESSAGE_MAP (CMainWindow, CDialog)
ON_BN_CLICKED (ID_SEND, OnSend)
END_MESSAGE_MAP ()
//------------------------------------------------------------------------
CMainWindow::CMainWindow (bool is_server)
: m_isServer(is_server)
{
//must init m_user first, since the Create() below
//will cause a call to OnInitDialog.
m_user[0] = 0;
DWORD i = sizeof(m_user);
::GetUserName(m_user, &i);
Create(IDD_DIALOG);
HICON hIcon = AfxGetApp ()->LoadIcon (IDI_ICON);
SetIcon(hIcon, TRUE);
if (isServer())
SetWindowText(_T("W32Chat v1.0 (ubu Server)"));
else
SetWindowText(_T("W32Chat v1.0"));
}
//------------------------------------------------------------------------
bool CMainWindow::isServer()
{
return m_isServer;
}
//------------------------------------------------------------------------
BOOL CMainWindow::OnInitDialog()
{
CDialog::OnInitDialog();
m_strBuffer = "w32chat Started...";
DisplayEdit().SetWindowText(m_strBuffer);
// Init the 'continue' data member to TRUE. The ReadThread ThreadFunc
// will use this data member to determine if it's time to shut down the
// thread.
m_bContinue = TRUE;
// Create the mailslots
m_pReadThread = AfxBeginThread (ThreadFunc, this, THREAD_PRIORITY_BELOW_NORMAL);
Sleep(100);
m_oSendSlot = new CSendSlot(SLOT_NAME, _T("*"));
Sleep(100);
m_oSendSlot->SendLogon(m_user);
// Limit the no of characters on the input edit
InputEdit().LimitText(INPUT_LIMIT);
return TRUE;
}
//------------------------------------------------------------------------
void CMainWindow::OnSend()
{
CString strTemp;
InputEdit().GetWindowText(strTemp);
if (!strTemp.IsEmpty() && strTemp[0] != ' ')
m_oSendSlot->Send(m_user, strTemp);
InputEdit().SetWindowText(_T(""));
InputEdit().SetFocus();
}
//-----------------------------------------------------------------------------
void CMainWindow::OnClose()
{
//tell the recv thread to discontinue
m_bContinue = FALSE;
//send a msg to unblock the read
m_oSendSlot->SendLogoff(m_user);
HANDLE hThread = m_pReadThread->m_hThread;
::WaitForSingleObject (hThread, INFINITE);
delete m_oSendSlot;
}
//-----------------------------------------------------------------------------
// This function handles the updating of the main display edit box.
void CMainWindow::AddText(const CString& oNewText)
{
// Set a buffer size that is less than the maximum buffer size of the
// edit control itself.
const int MAX_BUFFER = 20000;
// Update the new buffer with the incoming string and do some testing
// to avoid having the buffer of the Edit control overflow.
m_strBuffer += oNewText;
if (m_strBuffer.GetLength() > MAX_BUFFER)
m_strBuffer = m_strBuffer.Right(MAX_BUFFER);
// Update the text of the edit control and make sure that it is scrolled
// to the bottom
DisplayEdit().SetWindowText(m_strBuffer);
DisplayEdit().LineScroll(DisplayEdit().GetLineCount() - VISIBLE_LINES);
}
//-----------------------------------------------------------------------------
CEdit& CMainWindow::InputEdit()
{ return *(CEdit*) GetDlgItem(IDC_EDIT);
}
//-----------------------------------------------------------------------------
CEdit & CMainWindow::DisplayEdit()
{ return *(CEdit*) GetDlgItem(IDC_DISPLAY);
}
//-----------------------------------------------------------------------------
void CMainWindow::OnCancel()
{ DestroyWindow();
}
//-----------------------------------------------------------------------------
void CMainWindow::PostNcDestroy()
{
OnClose();
delete this;
}
//-----------------------------------------------------------------------------
UINT CMainWindow::ThreadFunc(LPVOID pParam)
{
CMainWindow* oThis = (CMainWindow*) pParam;
CRecvSlot oRecvSlot(SLOT_NAME);
UBUServer* ubu = 0;
if (oThis->isServer())
{
ubu = new UBUServer();
}
TCHAR szIncomingMsg[5000];
CString strFinal;
BOOL brc;
while (oThis->m_bContinue)
{
szIncomingMsg[0] = 0;
brc = oRecvSlot.GetMessage(szIncomingMsg);
//first check continue flag
if (!oThis->m_bContinue)
break;
if (brc && szIncomingMsg[0] != 0)
{
strFinal += L'\x0D';
strFinal += L'\x0A';
strFinal += szIncomingMsg;
oThis->AddText(strFinal);
if (ubu)
{
if (_tcsncmp(szIncomingMsg, _T("ubu:"), 4) != 0)
ubu->Put(szIncomingMsg);
}
strFinal.Empty();
}
}
delete ubu;
AfxEndThread(0);
return 0;
}
|
|
|
#pragma once
#include <afxwin.h>
class CSendSlot;
class CMainWindow : public CDialog
{
public:
CMainWindow (bool is_server);
CEdit& InputEdit();
CEdit & DisplayEdit();
void AddText(const CString& oNewText);
bool isServer();
protected:
static UINT ThreadFunc(LPVOID pParam);
virtual BOOL OnInitDialog();
virtual void OnCancel();
afx_msg void OnCreate();
afx_msg void OnClose();
afx_msg void OnSend();
virtual void PostNcDestroy();
DECLARE_MESSAGE_MAP ()
private:
TCHAR m_user[256];
bool m_isServer;
CWinThread * m_pReadThread;
BOOL m_bContinue;
CSendSlot * m_oSendSlot;
CString m_strBuffer;
};
|
|
|
#include <afxwin.h>
#include <tchar.h>
#include <atlbase.h>
#include <comdef.h>
#include "PerlCaller.h"
const CLSID CLSID_PerlCom =
{0xB5863EF3, 0x7B28, 0x11D1, {0x81, 0x06, 0x00, 0x00, 0xB4, 0x23, 0x43, 0x91}
};
void GetLastErrorDescription(CComBSTR& bstr); // Defined in PerlAddin.cpp
#define VERIFY_OK(f) \
{ \
HRESULT hr = (f); \
if (hr != S_OK) \
{ \
if (FAILED(hr)) \
{ \
CComBSTR bstr; \
GetLastErrorDescription(bstr); \
_RPTF2(_CRT_ASSERT, "Object call returned %lx\n\n%S", hr, (BSTR) bstr); \
} \
else \
_RPTF1(_CRT_ASSERT, "Object call returned %lx", hr); \
} \
}
extern CWinApp myApp;
#include "crtdbg.h"
#ifdef _DEBUG
#define MYDEBUG_NEW new(_NORMAL_BLOCK, __FILE__, __LINE__)
#define new MYDEBUG_NEW
#else
#define MYDEBUG_NEW
#endif // _DEBUG
//--------------------------------------------------------------------------------------
class pimplPerlCaller
{
public:
pimplPerlCaller();
bool Init();
bool Invoke(TCHAR* name, variant_t& in, variant_t& vReturn);
private:
void GetId(TCHAR* name, DISPID& dispid);
IDispatch* pDisp;
} ;
//--------------------------------------------------------------------------------------
pimplPerlCaller::pimplPerlCaller()
: pDisp(0)
{}
//--------------------------------------------------------------------------------------
bool pimplPerlCaller::Init()
{
HRESULT hr;
//create instance of perlcom
//this is a dispatch only interface...
//this was done so that individual sub's could be called in a script
hr = CoCreateInstance(CLSID_PerlCom, NULL, CLSCTX_INPROC_SERVER, IID_IDispatch, (void**) & pDisp);
return SUCCEEDED(hr) && pDisp;
}
//--------------------------------------------------------------------------------------
void pimplPerlCaller::GetId(TCHAR* name, DISPID& dispid)
{
_ASSERTE(pDisp);
_ASSERTE(name);
wchar_t* wname;
#ifndef UNICODE
wchar_t wn[1000];
MultiByteToWideChar( CP_ACP, // code page
MB_ERR_INVALID_CHARS, // character-type options
name, // address of string to map
strlen(name)+1, // number of characters in string
wn, // address of wide-character buffer
1000); // size of buffer
wname = wn;
#else
wname = name;
#endif
HRESULT hr = pDisp->GetIDsOfNames(IID_NULL, &wname, 1, LOCALE_USER_DEFAULT, &dispid);
_ASSERTE(SUCCEEDED(hr));
}
//--------------------------------------------------------------------------------------
bool pimplPerlCaller::Invoke(TCHAR* name, variant_t& in, variant_t& vReturn)
{
_ASSERTE(pDisp);
DISPID dispid = 0;
GetId(name, dispid);
VARIANT args[1];
args[0] = in;
DISPPARAMS dparms;
dparms.cArgs = 1;
dparms.cNamedArgs = 0;
dparms.rgdispidNamedArgs = NULL;
dparms.rgvarg = &args[0];
HRESULT hr = pDisp->Invoke(
dispid,
IID_NULL,
LOCALE_USER_DEFAULT,
DISPATCH_METHOD,
&dparms,
&vReturn,
NULL,
NULL);
if (hr == DISP_E_MEMBERNOTFOUND)
{
// VERIFY_OK(myApp.EnableModeless(VARIANT_FALSE));
AfxMessageBox(_T("Error excuting script"), MB_OK | MB_ICONINFORMATION);
// VERIFY_OK(myApp.EnableModeless(VARIANT_TRUE));
return false;
}
else if (hr == DISP_E_EXCEPTION)
{
// VERIFY_OK(myApp.EnableModeless(VARIANT_FALSE));
AfxMessageBox(_T("Script caused an exception...\nIs there a Run() method?"), MB_OK | MB_ICONINFORMATION);
// VERIFY_OK(myApp.EnableModeless(VARIANT_TRUE));
return false;
}
else
{
_ASSERTE(SUCCEEDED(hr));
}
return true;
}
//--------------------------------------------------------------------------------------
PerlCaller::PerlCaller()
{
m_Private = new pimplPerlCaller;
}
//--------------------------------------------------------------------------------------
PerlCaller::~PerlCaller()
{
delete m_Private;
}
//--------------------------------------------------------------------------------------
bool PerlCaller::Init(const CString& scriptname)
{
CoInitialize(0);
_ASSERTE(m_Private);
if (!m_Private->Init()) return false;
//we're going to create a wrapper sub around the user's script
EvalScript(scriptname);
return true;
}
//--------------------------------------------------------------------------------------
void PerlCaller::Term()
{
CoUninitialize();
}
//--------------------------------------------------------------------------------------
//-- just evaluate (i.e. compile) script
void PerlCaller::EvalScript(const CString& scriptname)
{
try
{
CStdioFile f(_T("__main__.pl"), CFile::modeRead);
_bstr_t tmp;
CString line;
while (f.ReadString(line))
{
int posn = line.Find(_T("XXXXXX"));
if (posn != -1)
{
CString s = line.Left(posn);
tmp += (LPCTSTR) s;
tmp += (LPCTSTR) scriptname;
s = line.Right(line.GetLength() - posn - 6);
tmp += (LPCTSTR) s;
}
//line.Replace(_T("XXXXXX"), scriptname);
tmp += (LPCTSTR)line;
tmp += _T("\n");
}
f.Close();
_variant_t v = tmp;
_variant_t vReturn;
//we're ready to invoke the eval
m_Private->Invoke(_T("EvalScript"), v, vReturn);
}
catch ( CFileException* )
{
_ASSERTE(0);
}
}
//--------------------------------------------------------------------------------------
//-- just evaluate (i.e. compile) script
void PerlCaller::ubu(const CString& currline, CString& out)
{
out.Empty();
//can't tell at this point whether the sub name exists or not
_variant_t v = currline;
_variant_t vReturn;
bool rc = m_Private->Invoke(_T("__main__"), v, vReturn);
if (rc)
{
out = (LPWSTR) (_bstr_t) vReturn;
}
}
//--------------------------------------------------------------------------------------
void GetLastErrorDescription(CComBSTR& bstr)
{
CComPtr < IErrorInfo > pErrorInfo;
if (GetErrorInfo(0, &pErrorInfo) == S_OK)
pErrorInfo->GetDescription(&bstr);
}
|
|
|
#pragma once
class pimplPerlCaller;
class PerlCaller
{
public:
PerlCaller();
~PerlCaller();
bool Init(const CString& scriptname);
void Term();
void ubu(const CString& currline, CString& out);
private:
void EvalScript(const CString& scriptname);
pimplPerlCaller* m_Private;
} ;
|
|
|
#include "RecvSlot.h"
#include <stdio.h>
#include "crtdbg.h"
#ifdef _DEBUG
#define MYDEBUG_NEW new(_NORMAL_BLOCK, __FILE__, __LINE__)
#define new MYDEBUG_NEW
#else
#define MYDEBUG_NEW
#endif // _DEBUG
//-----------------------------------------------------------------------------
CRecvSlot::CRecvSlot(const TCHAR szSlotName[])
{
iErrorState = 0;
_stprintf(szSlotPath, _T("\\\\.\\mailslot%s"), szSlotName);
hMailSlot = CreateMailslot(szSlotPath, 0, MAILSLOT_WAIT_FOREVER, (LPSECURITY_ATTRIBUTES) NULL);
iErrorState = GetLastError();
_ASSERTE(iErrorState == ERROR_SUCCESS || iErrorState == ERROR_ALREADY_EXISTS);
if (hMailSlot == INVALID_HANDLE_VALUE)
{
iErrorState = GetLastError();
return;
}
}
//-----------------------------------------------------------------------------
BOOL CRecvSlot::GetMessage(TCHAR szMessageText[])
{
DWORD dwNextSize;
DWORD dwMsgs;
DWORD dwNumBytesRead;
DWORD iErrorState;
BOOL bStatus;
BOOL brc;
TCHAR byteone;
brc = ReadFile(hMailSlot, &byteone, sizeof(byteone), &dwNumBytesRead, (LPOVERLAPPED) NULL);
iErrorState = GetLastError();
//if (!brc && iErrorState != ERROR_INSUFFICIENT_BUFFER)
// return FALSE;
// _ASSERTE(!brc && iErrorState == ERROR_INSUFFICIENT_BUFFER);
bStatus = ::GetMailslotInfo(hMailSlot, 0, &dwNextSize, &dwMsgs, 0);
if (!bStatus)
{
iErrorState = GetLastError();
return FALSE;
}
if (dwNextSize == MAILSLOT_NO_MESSAGE || dwMsgs == 0)
{
return FALSE;
}
if (!::ReadFile(hMailSlot, szMessageText, dwNextSize, &dwNumBytesRead, (LPOVERLAPPED) NULL))
{
// ERROR: Unable to read from mailslot
iErrorState = GetLastError();
return FALSE;
}
iErrorState = 0;
return TRUE;
}
|
|
|
#pragma once
#include "MailSlot.h"
class CRecvSlot : public CMailSlot
{
public:
CRecvSlot(const TCHAR szSlotName[]);
BOOL GetMessage(TCHAR szMessageText[]);
};
|
|
|
#define IDI_ICON 2
#define IDD_DIALOG 100
#define IDC_EDIT1 101
#define IDC_EDIT 101
#define IDC_LISTBOX1 102
#define IDC_EDIT2 102
#define IDC_DISPLAY 102
#define IDC_COMBOBOX1 103
#define LINE_1 -1
#define ID_CLOSE 2
#define ID_Close 2
#define ID_SEND 1
|
|
|
//{{NO_DEPENDENCIES}}
// Microsoft Developer Studio generated include file.
// Used by w32chat.rc
//
// Next default values for new objects
//
#ifdef APSTUDIO_INVOKED
#ifndef APSTUDIO_READONLY_SYMBOLS
#define _APS_NEXT_RESOURCE_VALUE 101
#define _APS_NEXT_COMMAND_VALUE 40001
#define _APS_NEXT_CONTROL_VALUE 1000
#define _APS_NEXT_SYMED_VALUE 101
#endif
#endif
|
|
|
#include <afxwin.h>
#include "SendSlot.h"
CSendSlot::CSendSlot(const TCHAR szSlotName[], const TCHAR szBroadcastRange[])
{
iErrorState = 0;
_stprintf(szSlotPath, _T("\\\\%s\\mailslot%s"), szBroadcastRange, szSlotName);
// Create the mailslot file handle for sending messages
hMailSlot = CreateFile(szSlotPath,
GENERIC_WRITE, FILE_SHARE_READ,
(LPSECURITY_ATTRIBUTES) NULL,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
(HANDLE) NULL);
// Check and see if the mailslot file was opened, if not terminate program
if (hMailSlot == INVALID_HANDLE_VALUE)
{
// ERROR: unable to create mailslot "
iErrorState = GetLastError();
}
}
//-----------------------------------------------------------------------------
int CSendSlot::Send(const TCHAR user[], const TCHAR str[])
{
CString s;
s += user;
s += ": ";
s += str;
return Send(s);
}
//-----------------------------------------------------------------------------
int CSendSlot::SendLogon(const TCHAR user[])
{
CString s;
s += user;
s += ": ";
s += "logging on";
return Send(s);
}
//-----------------------------------------------------------------------------
int CSendSlot::SendLogoff(const TCHAR user[])
{
CString s;
s += user;
s += ": ";
s += "bye bye";
return Send(s);
}
//-----------------------------------------------------------------------------
// returns 0 if send succesful, non-zero if send fails. Also, iErrorState is
// set with the return value.
int CSendSlot::Send(const TCHAR str[])
{
DWORD dwNumBytesWritten;
BOOL bStatus;
// Write message to mailslot
bStatus = WriteFile(hMailSlot,
str,
(DWORD) ((_tcslen(str) + 1)*sizeof(TCHAR)),
&dwNumBytesWritten,
(LPOVERLAPPED) NULL);
// If eror occours when writing to mailslot
if (!bStatus)
{
// ERROR: Unable to write to mailslot
iErrorState = GetLastError();
return iErrorState;
}
// Code executed when send is completed OK.
else
{
iErrorState = 0;
return 0; // Signal that the send wen't ok.
}
}
|
|
|
#pragma once
#include "MailSlot.h"
class CSendSlot: public CMailSlot
{
public:
CSendSlot(const TCHAR szSlotName[], const TCHAR szBroadcastRange[]);
int Send(const TCHAR user[], const TCHAR str[]);
int SendLogon(const TCHAR user[]);
int SendLogoff(const TCHAR user[]);
private:
int Send(const TCHAR str[]);
};
|
|
|
#include "UBUServer.h"
#include "SendSlot.h"
#include <comdef.h>
#include "PerlCaller.h"
//#import "c:\\program files\\outlook express\\msoe.dll"
#define WM_STRING WM_USER+1
//------------------------------------------------------------------------
UBUServer::UBUServer()
{
m_thread = AfxBeginThread(ThreadFunc, this, THREAD_PRIORITY_BELOW_NORMAL);
Sleep(10);
}
//------------------------------------------------------------------------
UBUServer::~UBUServer()
{
PostThreadMessage(m_thread->m_nThreadID, WM_QUIT, 0, 0);
WaitForSingleObject (m_thread->m_hThread, INFINITE);
Sleep(200);
}
//------------------------------------------------------------------------
void UBUServer::Put(LPCTSTR str)
{
PostThreadMessage(m_thread->m_nThreadID, WM_STRING, (WPARAM) new CString(str), 0);
}
//------------------------------------------------------------------------
UINT UBUServer::ThreadFunc(LPVOID /*pParam*/)
{
// UBUServer* This = (UBUServer*) pParam;
PerlCaller perl;
//This depends on the ubu.pl to be in the same directory as w32chat.exe
perl.Init(_T("ubu.pl"));
CSendSlot ss(SLOT_NAME, _T("*"));
ss.SendLogon(_T("ubu"));
CString out;
MSG msg;
while (GetMessage(&msg, 0, 0, 0))
{
if (msg.message != WM_STRING)
{
continue;
}
CString* str = (CString*) msg.wParam;
perl.ubu(*str, out);
if (!out.IsEmpty())
{
//break up the outgoing string into multiple lines
int i = 0;
int j = 0;
CString tmp;
for (; ;)
{
if (j >= out.GetLength())
break;
if (i < out.GetLength())
{
TCHAR ch = out.GetAt(i);
if (ch != L'\n' && ch != L'\0')
{
i++;
continue;
}
}
tmp = out.Mid(j, i - j);
ss.Send(_T("ubu"), tmp);
j = ++i;
}
}
delete str;
}
perl.Term();
return 0;
}
|
|
|
#pragma once
#include <afxwin.h>
class UBUServer
{
public:
UBUServer();
~UBUServer();
void Put(LPCTSTR str);
private:
static UINT ThreadFunc(LPVOID pParam);
CWinThread* m_thread;
} ;
|
|
|
#include "w32chat.h"
#include "MainWindow.h"
CMyApp myApp;
//------------------------------------------------------------------------
// CMyApp member functions
BOOL CMyApp::InitInstance ()
{
TCHAR szUserName[256];
unsigned long iSizeOf = sizeof(szUserName);
::GetUserName(szUserName, &iSizeOf);
bool is_server = false;
if (_tcscmp(szUserName, _T("arrizza")) == 0)
is_server = true;
TCHAR* szCmdLine = ::GetCommandLine();
if (_tcsstr(szCmdLine, "-server") != 0)
is_server = true;
m_pMainWnd = new CMainWindow(is_server);
m_pMainWnd->ShowWindow(m_nCmdShow);
m_pMainWnd->UpdateWindow();
return TRUE;
}
|
|
|
#pragma once
#include <afxwin.h>
class CMyApp : public CWinApp
{
public:
virtual BOOL InitInstance ();
};
|
|
|
//Microsoft Developer Studio generated resource script.
//
#include "resrc1.h"
#define APSTUDIO_READONLY_SYMBOLS
/////////////////////////////////////////////////////////////////////////////
//
// Generated from the TEXTINCLUDE 2 resource.
//
#include "afxres.h"
#include "resource.h"
/////////////////////////////////////////////////////////////////////////////
#undef APSTUDIO_READONLY_SYMBOLS
/////////////////////////////////////////////////////////////////////////////
// English (U.S.) resources
#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_ENU)
#ifdef _WIN32
LANGUAGE LANG_ENGLISH, SUBLANG_ENGLISH_US
#pragma code_page(1252)
#endif //_WIN32
/////////////////////////////////////////////////////////////////////////////
//
// Dialog
//
IDD_DIALOG DIALOG DISCARDABLE 2, 1, 338, 177
STYLE WS_MINIMIZEBOX | WS_POPUP | WS_CAPTION | WS_SYSMENU
CAPTION "Message MFC 1.0"
FONT 8, "MS Sans Serif"
BEGIN
EDITTEXT IDC_EDIT,5,138,328,15,ES_AUTOHSCROLL
DEFPUSHBUTTON "&Send",ID_SEND,105,159,130,14,BS_CENTER
EDITTEXT IDC_DISPLAY,5,8,328,124,ES_MULTILINE | ES_AUTOVSCROLL |
ES_READONLY
END
/////////////////////////////////////////////////////////////////////////////
//
// Icon
//
// Icon with lowest ID value placed first to ensure application icon
// remains consistent on all systems.
IDI_ICON ICON DISCARDABLE "w32chat.ico"
#ifdef APSTUDIO_INVOKED
/////////////////////////////////////////////////////////////////////////////
//
// TEXTINCLUDE
//
1 TEXTINCLUDE DISCARDABLE
BEGIN
"resrc1.h\0"
END
2 TEXTINCLUDE DISCARDABLE
BEGIN
"#include ""afxres.h""\r\n"
"#include ""resource.h""\r\n"
"\0"
END
3 TEXTINCLUDE DISCARDABLE
BEGIN
"\r\n"
"\0"
END
#endif // APSTUDIO_INVOKED
/////////////////////////////////////////////////////////////////////////////
//
// DESIGNINFO
//
#ifdef APSTUDIO_INVOKED
GUIDELINES DESIGNINFO DISCARDABLE
BEGIN
IDD_DIALOG, DIALOG
BEGIN
BOTTOMMARGIN, 173
END
END
#endif // APSTUDIO_INVOKED
#ifndef _MAC
/////////////////////////////////////////////////////////////////////////////
//
// Version
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 1,0,0,1
PRODUCTVERSION 1,0,0,1
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
#else
FILEFLAGS 0x0L
#endif
FILEOS 0x40004L
FILETYPE 0x1L
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BEGIN
BLOCK "040904b0"
BEGIN
VALUE "CompanyName", " \0"
VALUE "FileDescription", "w32chat\0"
VALUE "FileVersion", "1, 0, 0, 1\0"
VALUE "InternalName", "w32chat\0"
VALUE "LegalCopyright", "Copyright © 2000\0"
VALUE "OriginalFilename", "w32chat.exe\0"
VALUE "ProductName", " w32chat\0"
VALUE "ProductVersion", "1, 0, 0, 1\0"
END
END
BLOCK "VarFileInfo"
BEGIN
VALUE "Translation", 0x409, 1200
END
END
#endif // !_MAC
#endif // English (U.S.) resources
/////////////////////////////////////////////////////////////////////////////
#ifndef APSTUDIO_INVOKED
/////////////////////////////////////////////////////////////////////////////
//
// Generated from the TEXTINCLUDE 3 resource.
//
/////////////////////////////////////////////////////////////////////////////
#endif // not APSTUDIO_INVOKED
|
|
|
use strict;
$main::miscdir = '\\ubu';
$main::filesep = '\\';
$main::infobot_base_dir = '.\\ubu';
$main::infobot_src_dir = '.\\ubusrc'; #$infobot_base_dir.$filesep."src";
@main::paramfiles = ("ubu\\ubu.config");
#require "main::$infobot_src_dir\\ansi.pl";
require "$main::infobot_src_dir\\process.pl";
require "$main::infobot_src_dir\\user.pl";
require "$main::infobot_src_dir\\myRoutines.pl";
require "$main::infobot_src_dir\\Question.pl";
require "$main::infobot_src_dir\\reply.pl";
require "$main::infobot_src_dir\\dbm.pl";
require "$main::infobot_src_dir\\misc.pl";
require "$main::infobot_src_dir\\norm.pl";
require "$main::infobot_src_dir\\math.pl";
require "$main::infobot_src_dir\\setup.pl";
require "$main::infobot_src_dir\\params.pl";
require "$main::infobot_src_dir\\help.pl";
require "$main::infobot_src_dir\\statement.pl";
require "$main::infobot_src_dir\\update.pl";
#optional...
require "$main::infobot_src_dir\\DNS.pl";
require "$main::infobot_src_dir\\Internic.pl";
require "$main::infobot_src_dir\\Traceroute.pl";
require "$main::infobot_src_dir\\NOAA.pl";
require "$main::infobot_src_dir\\METAR2.pl";
require "$main::infobot_src_dir\\babel.pl";
require "$main::infobot_src_dir\\slashdot3.pl";
require "$main::infobot_src_dir\\nickometer.pl";
require "$main::infobot_src_dir\\insult.pl";
sub say {
my $msg=$_[0];
&status("<xxx> $msg");
#rawout("PRIVMSG <xxx> :$msg");
rawout("$msg");
}
sub channel {
1;
}
sub msg {
my ($nick, $msg) = @_;
&status(">$nick< $msg");
#rawout("PRIVMSG $nick :$msg");
rawout("$nick, $msg");
}
my $outline;
sub rawout
{
my $buf = $_[0];
$buf =~ s/\n//gi;
#print "$buf\n";
&status("rawout: $buf");
if ($outline)
{
$outline = $outline . "\n". $buf;
}
else
{
$outline = $buf;
}
}
sub doLine($$$)
{
my ($user, $type, $msg) = @_;
my $s = process($user, $type, $msg);
&status("main: $s") unless $s eq 'NOREPLY' or $s eq '' or $s eq '1';
$outline = $s unless ($s eq 'NOREPLY' or $s eq ''or $s eq '1');
}
setup();
$main::param{nick} = $main::param{wantNick};
$main::nuh = "jaa!ja\@gil.com";
$main::updateCount = 0;
$main::questionCount = 0;
sub __main__($)
{
$outline = '';
my $s = shift @_;
my ($user, $msg) = $s =~ /(.*): (.*)$/;
doLine($user, 'public', $msg);
if ($outline)
{
return $outline;
}
else
{
return '';
}
return 'hi there';
}
|
|
|
what => <reply>
who => <reply>
when => <reply>
where => <reply>
why => <reply>
it => <reply>
|
|
|
*cthulhu!hastur@*unspeakable.net # an example nick!user@host ban
*!*@*nan*direct.ca
*!*@200.38.211.*
|
|
|
what => <reply>
who => <reply>
when => <reply>
where => <reply>
why => <reply>
it => <reply>
how => <reply>
infobot guide => http://www.cs.cmu.edu/~infobot/infobot_guide.html
|
|
|
roses => red
violets => blue
|
|
|
oznoid => at mailto:lenzo@cs.cmu.edu or at http://www.cs.cmu.edu/~lenzo
infobot => at http://www.cs.cmu.edu/~infobot
|
|
|
# parameter settings file for the infobot
# kevin lenzo (lenzo@cs.cmu.edu)
# note:
# '$var' means a parameter that has been named; it is interpolated.
# By convention, things with '.ext' (extensions) are text files, and
# things with hyphens in them are DBM file prefixes, used for run-time
# learning or state maintenance.
#
# Nota Bene: Comment out attributes you don't want. Note that the
# word "false" is actually a true value! use 0 or comment
# out options you don't want.
# How much verbage to display on the console
#VERBOSITY 99
# the internal name for this bot
ident ubu
# where configuration and help files and such live
miscdir .\\ubu
# where to put logging info
logfile .\\ubu\\$ident.log
# the nickname we want
wantNick $ident
# the prefix of the dbm files
dbname $ident
# plusplus, an idea hijacked from CMU zephyr community,
# and dkindred++ in particular. Otherwise known
# as 'karma'. this is persistant between shutdowns.
plusplus $ident-karma
# persistant "seen" db
seen $ident-seen
# do we have an ignore database? uncomment this if not.
ignore $ident-ignore
# should we ALWAYS close and reopen dbm on update?
# some systems don't do commitment until quit.
#
# 0 => never force sync
# 1 => force sync on every update
# N => force sync every Nth update
commitDBM 5
# X is Y
# max length of X (the key,
# the 'left hand side' (LHS) of an assignment,
# or the first argument)
maxKeySize 50
# max length of Y (value or data, the 'right hand side', or 2nd argument)
maxDataSize 1000
# REQUIRE, OPTIONAL, REJECT for different behaviour with URLs
# REQUIRE means it will need to be a url type (e.g. file:, http:)
# OPTIONAL will take anything
# REJECT will not accept any urls. this makes it easy to
# run 2 with different nicks and styles.
acceptUrl OPTIONAL
# IRC-related params
ircuser $ident
realname $ident
server irc.cs.cmu.edu
port 6667
allowed_channels #infobot #$ident
# channels to join
# use #channel,key (thanks to tile++) for keyed channels
join_channels #infobot #$ident
# server password, if needed
# server_pass myserverpassword
# vhost support... if you have a vhost, you can use this,
# otherwise it won't work.
# inm++, elph++ for this :)
# vhost_name f00.bar.org
# addressing is when you name the bot. if this is REQUIRE,
# the bot should only speak when spoken to. BUT it may listen.
# anything else will mean it can barge in when it thinks it
# knows something.
# "shutup" determines whether you can switch modes on the
# fly with the bot. if you use REQUIRE for addressing, you
# probably want to comment out the shutup line.
addressing OPTIONAL
shutup TRUE
# ansi screen control is available from 0.32 onwards
# value of 1 means to use ANSI, 0 means generic bold
#ansi_control 1
# things we may or may not want to allow. 1 = allow, 0 otherwise.
# do you want to be a desktop calc?
perlMath 1
fortranMath 0
# do you want to allow DNS lookup/Internic/Traceroute?
allowDNS 1 jaa: can't allow this for now; fork function now supported by perl
allowTraceroute 1 #jaa: can't allow this for now; fork function now supported by perl
allowInternic 1 # jaa: can't allow this; fork function now supported by perl
# ord/chr etc
allowConv 1 #jaa: doesn't work.
# tell so-and-so about such-and-such
allowTelling 1
# let any old joe update stuff. if this is 0, you'll have to
# either change some code, do everything with e.g. make_db,
# or do something else arcane to get factoids in.
allowUpdate 1
# the magic hack word to unignore everyone
unignoreWord unignore-everyone
# my help file. this will get miscdir prepended
# you may want to change this to $ident.help
helpfile infobot.help
# within how long of getting the same reply should
# we not respond (irc mode only). in seconds.
repeatIgnoreInterval 8
# in what contexts do we let people make the bot leave a
# channel (this is an or'd list; public private)
allowLeave public
# our user list default file (in miscdir)
# you may want to change this to $ident.users
userList $ident.users
# default quit message
quitMsg regrouping; bbiab
# how long does something have to be before we'll just volunteer
# the answer without a question mark, question, or being addressed
minVolunteerLength 8
# other bots to ask for help
# friendlyBots url purl script mrapi
# sane defines that ALWAYS overwrite existing values at startup
# this is a prefix for the files (sane-is.txt, sane-are.txt)
sanePrefix sane
# allow weather and METAR lookups, respectively. These should
# actually be turned into a user modes. mendel++. Require
# LWP and metar requires Geo::METAR.
#weather true #jaa: these don't work for some reason
#metar true
# babelfish translator. jdf++. requires LWP, not included.
#babel true #jaa: does not wrok
# slashdot headlines. requires LWP, not included. get it from CPAN.
slash true
# insult server
#insult true #jaa: require Net::telnet
# google search.. simon++ . expanded to www search using several
# engines since it was so easy once you have WWW::Search.
# use "update" if you want it to update the db, or comment
# out if you don't want it. requires WWW::Search, not included.
# use "forceupdate" to force a db update on every google search.
wwwsearch update
|
|
|
#
# User File (c) 1998 Infobot & Associates
#
# FLAGS
# ----------------------
# i Ignored Flag
# f MLF Usage Allowed
# t Teaching Allowed
# r Removing Allowed
# m Modifying Allowed
# c Part/Join Allowed
# s Searching Allowed (possibly computationally expensive)
# S user can make bot Say things
# e Extra Privs [ not implemented robustly: AVOID ]
# p oP on channel by public request
# ----------------------
# o Owner Flag
# ----------------------
#
# recommended default user flags: +trmc
UserEntry default {
flags +trmcs;
}
# here's an example entry
UserEntry oznoid {
name "Kevin A. Lenzo";
title "that guy";
flags +ftrmcsSope;
pass rrmrxB6U4ryRk;
mask *!lenzo@*.speech.cs.cmu.edu;
}
UserEntry plonk {
name "Eep Malloy"
title "that guy II";
flags +trmcspo;
pass rrmrxB6U4ryRk;
mask *!*@*.static.telerama.com
}
|
|
|
require 5.001;
%attributes = ('clear' => 0,
'reset' => 0,
'bold' => 1,
'underline' => 4,
'underscore' => 4,
'blink' => 5,
'reverse' => 7,
'concealed' => 8,
'black' => 30, 'on_black' => 40,
'red' => 31, 'on_red' => 41,
'green' => 32, 'on_green' => 42,
'yellow' => 33, 'on_yellow' => 43,
'blue' => 34, 'on_blue' => 44,
'magenta' => 35, 'on_magenta' => 45,
'cyan' => 36, 'on_cyan' => 46,
'white' => 37, 'on_white' => 47);
$b_black = cl('bold black'); $_black = cl('black');
$b_red = cl('bold red'); $_red = cl('red');
$b_green = cl('bold green'); $_green = cl('green');
$b_yellow = cl('bold yellow'); $_yellow = cl('yellow');
$b_blue = cl('bold blue'); $_blue = cl('blue');
$b_magenta = cl('bold magenta'); $_magenta = cl('magenta');
$b_cyan = cl('bold cyan'); $_cyan = cl('cyan');
$b_white = cl('bold white'); $_white = cl('white');
$_reset = cl('reset'); $_bold = cl('bold');
$ob = cl('reset'); $b = cl('bold');
############################################################################
# Implementation (attribute string form)
############################################################################
# Return the escape code for a given set of color attributes.
sub cl {
my @codes = map { split } @_;
my $attribute = '';
foreach (@codes) {
$_ = lc $_;
unless (defined $attributes{$_}) { die "Invalid attribute name $_" }
$attribute .= $attributes{$_} . ';';
}
chop $attribute;
($attribute ne '') ? "\e[${attribute}m" : undef;
}
# Given a string and a set of attributes, returns the string surrounded by
# escape codes to set those attributes and then clear them at the end of the
# string. If $EACHLINE is set, insert a reset before each occurrence of the
# string $EACHLINE and the starting attribute code after the string
# $EACHLINE, so that no attribute crosses line delimiters (this is often
# desirable if the output is to be piped to a pager or some other program).
sub c {
my $string = shift;
if (defined $EACHLINE) {
my $attr = cl (@_);
join $EACHLINE,
map { $_ ne "" ? $attr . $_ . "\e[0m" : "" }
split ($EACHLINE, $string);
} else {
cl (@_) . $string . "\e[0m";
}
}
1;
|
|
|
# This program is copyright Jonathan Feinberg 1999.
# This program is distributed under the same terms as infobot.
# Jonathan Feinberg
# jdf@pobox.com
# http://pobox.com/~jdf/
# Version 1.0
# First public release.
package babel;
use strict;
my $no_babel;
BEGIN {
eval "use URI::Escape"; # utility functions for encoding the
if ($@) { $no_babel++}; # babelfish request
eval "use LWP::UserAgent";
if ($@) { $no_babel++};
}
BEGIN {
# Translate some feasible abbreviations into the ones babelfish
# expects.
use vars qw!%lang_code $lang_regex!;
%lang_code = (
fr => 'fr',
sp => 'es',
po => 'pt',
pt => 'pt',
it => 'it',
ge => 'de',
de => 'de',
gr => 'de',
en => 'en'
);
# Here's how we recognize the language you're asking for. It looks
# like RTSL saves you a few keystrokes in #perl, huh?
$lang_regex = join '|', keys %lang_code;
}
sub forking_babelfish {
return '' if $no_babel;
my ($direction, $lang, $phrase, $callback) = @_;
$SIG{CHLD} = 'IGNORE';
my $pid = eval { fork() }; # catch non-forking OSes and other errors
return if $pid; # parent does nothing
$callback->(babelfish($direction, $lang, $phrase));
exit 0 if defined $pid; # child exits, non-forking OS returns
}
sub babelfish {
return '' if $no_babel;
my ($direction, $lang, $phrase) = @_;
$lang = $lang_code{$lang};
my $ua = new LWP::UserAgent;
$ua->timeout(4);
my $req =
HTTP::Request->new('POST',
'http://babelfish.altavista.digital.com/cgi-bin/translate');
$req->content_type('application/x-www-form-urlencoded');
my $tolang = "en_$lang";
my $toenglish = "${lang}_en";
if ($direction eq 'to') {
return translate($phrase, $tolang, $req, $ua);
}
elsif ($direction eq 'from') {
return translate($phrase, $toenglish, $req, $ua);
}
my $last_english = $phrase;
my $last_lang;
my %results = ();
my $i = 0;
while ($i++ < 7) {
last if $results{$phrase}++;
$last_lang = $phrase = translate($phrase, $tolang, $req, $ua);
last if $results{$phrase}++;
$last_english = $phrase = translate($phrase, $toenglish, $req, $ua);
}
return $last_english;
}
sub translate {
return '' if $no_babel;
my ($phrase, $languagepair, $req, $ua) = @_;
my $urltext = uri_escape($phrase);
$req->content("urltext=$urltext&lp=$languagepair&doit=done");
my $res = $ua->request($req);
if ($res->is_success) {
my $html = $res->content;
# This method subject to change with the whims of Altavista's design
# staff.
my ($translated) =
($html =~ m{<br>
\s+
<font\ face="arial,\ helvetica">
\s*
(?:\*\*\s+time\ out\s+\*\*)?
\s*
([^<]*)
}sx);
$translated =~ s/\n/ /g;
$translated =~ s/\s*$//;
return $translated;
} else {
return ":("; # failure
}
}
"Hello. I'm a true value.";
|
|
|
# infobot (c) 1997 Lenzo
sub parsectcp {
my ($nick, $user, $host, $type, $dest) = @_;
&status("CTCP $type $dest request from $nick");
if ($type =~ /^version/i) {
ctcpreply($nick, "VERSION", $version);
} elsif ($type =~ /^(echo|ping) ?(.*)/i) {
# thanks to hcf! bugs on bugs.
# thanks to behe (ericw@ix.netcom.com)
# and wix
rawout("NOTICE $nick :\001PING $1\001");
# ctcpreply($nick, uc($1)." $2");
} elsif ($type =~ /^DCC /) {
&status("DCC attempt from $who (not supported, ignored)");
}
}
sub ctcpReplyParse {
my ($nick, $user, $host, $type, $reply) = @_;
&status("CTCP $type reply from $nick: $reply");
}
sub ctcpreply {
my ($rnick, $type, $reply) = @_;
rawout("NOTICE $rnick :\001$type $reply\001");
}
1;
|
|
|
#!/usr/bin/perl
$dbmdir = "/home/infobot/";
$dbmpref = "infobot";
&opendbs;
if (@ARGV) {
$query = join(" ", @ARGV);
&respond($query);
} else {
print "> ";
while (<>) {
last if /^\/?quit/i;
chomp;
if (/s^\/eval\s+/) {
$x = eval($_);
print $x;
} else {
&respond($_);
}
print "> ";
}
}
sub opendbs {
my $dp = "$dbmdir/$dbmpref";
dbmopen(%is, "$dbmdir/$dbmpref-is", undef)
|| die "can't open $dbmdir/$dbmpref-is -- please set path";
dbmopen(%are, "$dbmdir/$dbmpref-are", undef)
|| die "can't open $dbmdir/$dbmpref-are";
}
sub checkdbs {
my @reply;
foreach $k (@_) {
push @reply, $is{$k} if $is{$k};
push @reply, $are{$k} if $are{$k};
}
return @reply;
}
sub respond {
my $query = $_[0];
my @r;
$query =~ tr/A-Z/a-z/;
$query =~ s/wh\S+\s+(is|are)\s+//;
$query =~ s/\s*\?\s*$//;
if ($query =~ /\s+(are|is)\s+/i) {
$lhs = $`; $verb = $1; $rhs = $';
chomp $rhs;
$$verb{$lhs} = $rhs;
} else {
if (@r = &checkdbs($query)) {
foreach (@r) {
chomp;
print "$_\n";
}
} else {
print "undefined: $query\n";
}
}
}
sub dump {
foreach (keys %is) {
print "$_ => $is{$_}\n";
}
}
|
|
|
# infobot :: Kevin Lenzo (c) 1997
$DBformat = "lllll";
$DBprefix = 'HASH_';
if (!$filesep)
{
$filesep = '/';
}
sub openDBM
{
my %newDBMS = @_;
my $created = 0;
my $failed = 0;
# wix++ {
# tie %seen, 'DB_File', "tree", O_RDWR|O_CREAT, 0644, $DB_BTREE;
# tie %maillist, 'DB_File', "users", O_RDWR|O_CREAT, 0644, $DB_BTREE;
# }
foreach $d (keys %newDBMS)
{
next if $d =~ /^\s*$/;
if (defined($DBMS{$d}))
{
&status("$newDBMS{$d} replaces $DBMS{$d}")
unless $DBMS{$d} eq $newDBMS{$d};
}
if (dbmopen(%{"$DBprefix$d"}, $newDBMS{$d}, undef))
{
&status("opened $d -> $newDBMS{$d}");
$DBMS{$d} = $newDBMS{$d};
}
else
{
if (dbmopen(%{"$DBprefix$d"}, $newDBMS{$d}, 0644))
{
&status("created new db\t$d -> $newDBMS{$d}");
$DBMS{$d} = $newDBMS{$d};
$created++;
my $c = 0;
my $initfile = "$param{miscdir}/$param{'ident'}-$d.txt";
my $dbname = $DBprefix.$d;
&insertFile($initfile, $dbname);
}
else
{
&status("failed to open $d -> $newDBMS{$d}");
++$failed;
}
}
}
return $failed;
}
sub insertFile
{
my ($factfile, $dbname) = @_;
if (open(IN, $factfile))
{
my ($good, $total);
while (<IN>)
{
chomp;
my ($k, $v) = split(/\s*=>\s*/, $_, 2);
if ($k and $v)
{
$$dbname{$k} = $v;
$good++;
}
$total++;
}
close(IN);
$dbname =~ s/^HASH_//;
&status("loaded $factfile into $dbname ($good/$total good items)");
}
else
{
$dbname =~ s/^HASH_//;
&status("FAILED to load $factfile into $dbname");
}
}
sub closeDBM
{
untie %seen;
untie %maillist;
if (@_)
{
foreach $d (@_)
{
dbmclose(%{"$DBprefix$d"});
&status("closed db $d");
}
}
else
{
&status("No dbs specified; none closed");
}
}
sub set
{
my ($db, $key, $val) = @_;
my %dbs = %DBMS;
if (!$key)
{
($db, $key, $val) = split(/\s+/, $db);
}
# this is a hack to keep set param consistant.. overloaded
if ($db eq 'param')
{
my $was = $param{$key};
$param{$key} = $val;
return $was;
}
$dbname = "$DBprefix$db";
my $was = $$dbname{$key};
$$dbname{$key} = $val;
#if ($param{'commitDBM'} eq 'ALWAYS') {
# close and reopen the dbm file on each update.
# what a pain. some implemenations commit to
# disk on every update; some, however, do not.
# if you don't do this on the ones that do not,
# you can lose all new updates if the process
# dies.
# &closeDBM($db);
# my $trycount = 0;
# while ((++$trycount < 10) && &openDBM($db => $dbs{$db})) {
# sleep 1;
# }
#} elsif ($param{'commitDBM'} =~ /^\d+/) {
# if (!(++$strobe % $param{'commitDBM'})) {
# # close and reopen the dbm file every N
# # allow a refractory period. the dbm takes some time
# # to close and reopen. this is safer but still
# # a rather stupid way to do this.
# &closeDBM($db);
# my $trycount = 0;
# while ((++$trycount < 10) && &openDBM($db => $dbs{$db})) {
# sleep 1;
# }
# }
#}
return $was;
}
sub get
{
my ($db, $key) =@_;
if (!$key)
{
($db, $key) = split(/\s+/, $db);
}
$db = "$DBprefix$db";
return ${$db}{$key};
}
sub whatdbs
{
my @result;
foreach (keys %DBMS)
{
push(@result, "$_ => $DBMS{$_}");
}
return @result;
}
sub showdb
{
my ($db, $regex) = @_;
my @result;
if (!$regex)
{
($db, $regex) = split(/\s+/,$db, 2);
}
my @whichdbs;
if (!$db)
{
&status("no db given");
&status("try showdb <db> <regex>");
# @whichdbs = (keys %DBMS);
}
else
{
@whichdbs = ($db);
}
foreach $db (@whichdbs)
{
my $thedb = "$DBprefix$db";
if (!defined($DBMS{$db}))
{
&status("the database $db is not open.");
&status("try showdb <db> <regex>");
return ();
}
if (!$regex)
{
&status("showing all of $db");
foreach (keys %{$thedb})
{
push(@result, "$_ $db ${$thedb}{$_}");
}
}
else
{
&status("searching $db for /$regex/");
my $k;
foreach $k (keys %{$thedb})
{
my $v = $$thedb{$k};
if (($k =~ /$regex/) || ($v =~ /$regex/))
{
push(@result, "$k $db ${$thedb}{$k}");
}
}
}
}
return @result;
}
sub forget
{
&clear(@_);
return '';
}
sub clear
{
my ($db, $key) =@_;
if (!$key)
{
($db, $key) = split(/\s+/, $db);
}
my $thedb = "$DBprefix$db";
my $was = get($db, $key);
print "DELETING $thedb $key \n";
delete $$thedb{$key};
print "DELETED\n";
return '';
}
sub getDBMKeys
{
my $what = $_[0];
return keys %{"$DBprefix$what"};
}
sub basename
{
my $x = $_[0];
$x =~ s/.*\///;
return $x;
}
1;
|
|
|
# infobot :: Kevin Lenzo (c) 1997
# once again, thanks to Patrick Cole
#use POSIX;
use Socket;
sub REAPER {
$SIG{CHLD} = \&REAPER; # loathe sysV
$waitedpid = wait;
}
$SIG{CHLD} = \&REAPER;
$DNS_CACHE_EXPIRE_TIME = 7*24*60*60;
sub DNS {
my $in = $_[0];
my($match, $x, $y, $result);
if (($DNS_CACHE{$in}) && ((time()-$DNS_TIME_CACHE{$in}) < $DNS_CACHE_EXPIRE_TIME)) {
return $DNS_CACHE{$in};
}
if (!defined($pid = fork)) {
return "no luck, $safeWho";
} elsif ($pid) {
# parent
} else {
# child
if ($in =~ /(\d+\.\d+\.\d+\.\d+)/) {
&status("DNS query by IP address: $in");
$match = $1;
$y = pack('C4', split(/\./, $match));
$x = (gethostbyaddr($y, &AF_INET));
if ($x !~ /^\s*$/) {
$result = $match." is ".$x unless ($x =~ /^\s*$/);
} else {
$result = "I can't seem to find that address in DNS";
}
} else {
&status("DNS query by name: $in");
$x = join('.',unpack('C4',(gethostbyname($in))[4]));
if ($x !~ /^\s*$/) {
$result = $in." is ".$x;
} else {
$result = "I can\'t find that machine name";
}
}
$DNS_TIME_CACHE{$in} = time();
$DNS_CACHE{$in} = $result;
if ($msgType eq 'public') {
&say($result);
} else {
&msg($who, $result);
}
exit; # bye child
}
}
1;
|
|
|
#!/usr/bin/perl
if (!@ARGV || grep /^-/, @ARGV) {
print "\n";
print " usage: $0 <dbname>\n";
print "\n";
print " prints out an ascii flat file of the\n";
print " database <dbname>. <dbname> should be\n";
print " the basename of the db, e.g.\n";
print "\n";
print " $0 infobot-is\n";
print "\n";
exit(1);
}
foreach $dbname (@ARGV) {
dbmopen(%db, $dbname, undef) || die "Couldn't dbmopen \"$dbname\"";
$| = 1;
my $key;
foreach $key (keys %db) {
my $val = $db{$key};
chomp $val;
print "$key => $val\n";
}
dbmclose(%db);
}
|
|
|
#!/usr/bin/perl
# kevin lenzo
# run infobot.track through here to get the
# enters and updates in order. Adding these
# in order should give you the db as it was.
while (<>) {
next unless s/.*: (enter|update): //;
next if /FAILED/;
chomp;
s/\'; was .*//;
s/\'\s*$//;
s/.*?\'//;
print "$_\n";
}
|
|
|
# infobot :: Kevin Lenzo (c) 1997
sub setup_help {
$filesep ||= '/';
if (!exists $param{'helpfile'}) {
$param{'helpfile'} = "$infobot.help"; # murrayb++
}
if (open (HELP, "$infobot_src_dir$filesep$param{helpfile}")) {
undef %help;
while ($help = <HELP>) {
$help =~ s/\#.*//;
chomp $help;
next unless $help;
($key, $val) = split(/:/, $help, 2);
if (!$help{$key}) {
$helptopics .= "$key ";
}
if ($help{$key}) {
$help{$key} .= $val."\n";
} else {
$help{$key} = $val."\n";
}
}
$helptopics =~ s/\s+$//;
&status("Loaded help file $param{helpfile}");
} else {
$help{"main"} = "couldn't find the help file";
&status("No help file $param{helpfile}");
}
}
sub help {
my $topic = $_[0];
if ($topic =~ /^\s*$/) {
$topic = "main";
}
$topic =~ s/^\s*//;
$topic =~ s/\s*$//;
$topic =~ s/\s+/ /;
$topic =~ tr/A-Z/a-z/;
if ($help{$topic}) {
foreach (split(/\n/, $help{$topic})) {
&msg($who,$_);
}
} else {
&msg($who, "no help on $topic");
}
&msg($who, 'topics: '.$helptopics.". use 'help <topic>'.");
return '';
}
1;
|
|
|
#!/usr/local/bin/perl
# infobot -- copyright kevin lenzo (c) 1997-infinity
# no warrantee expressed or implied. terms as the
# license for X11R6 when needed.
BEGIN {
$filesep = '/';
# set this to the absolute path if you need it; especially
# if . is not in your path
$infobot_base_dir = '.'; # '/usr/local/lib/infobot/';
$infobot_src_dir = $infobot_base_dir.$filesep."src";
# change this next line if you run a local instance of
# an infobot and use the code from the main location.
# the 'files' directory contains infobot.config and
# infobot.users, among other things.
$initmiscdir = $infobot_base_dir.$filesep.'files';
# $initmiscdir = '/my_dir/files';
$param{'miscdir'} = $initmiscdir;
# these are here individually so you can mix
# and match code segments for different infobots.
# everything is loaded, then the variables that
# you want to set will override the defaults; this
# is why all these requires are here.
opendir DIR, $infobot_src_dir
or die "can't open source directory $infobot_src_dir: $!";
while ($file = readdir DIR) {
next unless $file =~ /\.pl$/;
require "$infobot_src_dir$filesep$file";
}
closedir DIR;
}
# get the command line arguments
&getArgs();
# initialize everything
&setup();
# launch the irc event loop
&irc();
exit 0; # just so you don't look farther down in this file :)
# --- support routines
sub usage {
print "\n";
print " usage: $0 [-h] [<paramfile1> [<pf2> ...]]\n";
print "\n";
print " -h this message\n";
print "\n";
}
sub getArgs {
if (@ARGV) {
while (@ARGV) {
my $arg = shift @ARGV;
if ($arg =~ s/^-//) {
# switchies
if ($arg eq 'i') {
# go into irc mode despite db setting
$overrideMode = 'IRC';
} else {
# -h is in here by default
&usage;
exit(1);
}
} else {
# no switchie. currently assumed to be
# a paramfile by default
push @paramfiles, $arg;
}
}
} else {
@paramfiles = ();
}
}
1;
|
|
|
# parameter settings file for the infobot
# kevin lenzo (lenzo@cs.cmu.edu)
# note:
# '$var' means a parameter that has been named; it is interpolated.
# By convention, things with '.ext' (extensions) are text files, and
# things with hyphens in them are DBM file prefixes, used for run-time
# learning or state maintenance.
#
# Nota Bene: Comment out attributes you don't want. Note that the
# word "false" is actually a true value! use 0 or comment
# out options you don't want.
# How much verbage to display on the console
VERBOSITY 99
# the internal name for this bot
ident ubu
# where to put logging info
logfile $ident.log
# the nickname we want
wantNick $ident
# the prefix of the dbm files
dbname $ident
# plusplus, an idea hijacked from CMU zephyr community,
# and dkindred++ in particular. Otherwise known
# as 'karma'. this is persistant between shutdowns.
plusplus $ident-karma
# persistant "seen" db
seen $ident-seen
# do we have an ignore database? uncomment this if not.
ignore $ident-ignore
# should we ALWAYS close and reopen dbm on update?
# some systems don't do commitment until quit.
#
# 0 => never force sync
# 1 => force sync on every update
# N => force sync every Nth update
commitDBM 5
# X is Y
# max length of X (the key,
# the 'left hand side' (LHS) of an assignment,
# or the first argument)
maxKeySize 50
# max length of Y (value or data, the 'right hand side', or 2nd argument)
maxDataSize 400
# REQUIRE, OPTIONAL, REJECT for different behaviour with URLs
# REQUIRE means it will need to be a url type (e.g. file:, http:)
# OPTIONAL will take anything
# REJECT will not accept any urls. this makes it easy to
# run 2 with different nicks and styles.
acceptUrl OPTIONAL
# IRC-related params
ircuser $ident
realname $ident
server irc.cs.cmu.edu
port 6667
allowed_channels #infobot #$ident
# channels to join
# use #channel,key (thanks to tile++) for keyed channels
join_channels #infobot #$ident
# server password, if needed
# server_pass myserverpassword
# vhost support... if you have a vhost, you can use this,
# otherwise it won't work.
# inm++, elph++ for this :)
# vhost_name f00.bar.org
# addressing is when you name the bot. if this is REQUIRE,
# the bot should only speak when spoken to. BUT it may listen.
# anything else will mean it can barge in when it thinks it
# knows something.
# "shutup" determines whether you can switch modes on the
# fly with the bot. if you use REQUIRE for addressing, you
# probably want to comment out the shutup line.
addressing OPTIONAL
shutup TRUE
# ansi screen control is available from 0.32 onwards
# value of 1 means to use ANSI, 0 means generic bold
#ansi_control 1
# things we may or may not want to allow. 1 = allow, 0 otherwise.
# do you want to be a desktop calc?
perlMath 1
fortranMath 0
# do you want to allow DNS lookup/Internic/Traceroute?
allowDNS 1
allowTraceroute 1
allowInternic 1
# ord/chr etc
allowConv 1
# tell so-and-so about such-and-such
allowTelling 1
# let any old joe update stuff. if this is 0, you'll have to
# either change some code, do everything with e.g. make_db,
# or do something else arcane to get factoids in.
allowUpdate 1
# the magic hack word to unignore everyone
unignoreWord unignore-everyone
# where configuration and help files and such live
miscdir ./ubu
# my help file. this will get miscdir prepended
# you may want to change this to $ident.help
helpfile infobot.help
# within how long of getting the same reply should
# we not respond (irc mode only). in seconds.
repeatIgnoreInterval 8
# in what contexts do we let people make the bot leave a
# channel (this is an or'd list; public private)
allowLeave public
# our user list default file (in miscdir)
# you may want to change this to $ident.users
userList infobot.users
# default quit message
quitMsg regrouping; bbiab
# how long does something have to be before we'll just volunteer
# the answer without a question mark, question, or being addressed
minVolunteerLength 8
# other bots to ask for help
# friendlyBots url purl script mrapi
# sane defines that ALWAYS overwrite existing values at startup
# this is a prefix for the files (sane-is.txt, sane-are.txt)
sanePrefix sane
# allow weather and METAR lookups, respectively. These should
# actually be turned into a user modes. mendel++. Require
# LWP and metar requires Geo::METAR.
#weather true
#metar true
# babelfish translator. jdf++. requires LWP, not included.
#babel true
# slashdot headlines. requires LWP, not included. get it from CPAN.
slash true
# insult server
insult true
# google search.. simon++ . expanded to www search using several
# engines since it was so easy once you have WWW::Search.
# use "update" if you want it to update the db, or comment
# out if you don't want it. requires WWW::Search, not included.
# use "forceupdate" to force a db update on every google search.
#wwwsearch update
|
|
|
*/5 * * * * /usr/users/you/infobot0.1b/run_infobots.pl > /dev/null
|
|
|
main: i learn mainly by observing declarative statements such as "x is at http://www.xxx.com", and then reply when people ask things like "where can i find x?"
author: oznoid (mailto:lenzo@ri.cmu.edu) is my author.
fixes: If I come back with "...but x is at http://xx.xx.xx" or something like that, and you want to change the entry, use "no, x is at http://sdfsdfsdf". The "No," tells me to supercede the existing value.
append: You can add to an entry with "also". "X is also at ..."
forget: You can delete an entry with . "forget X"
reply: There is a special tag, <reply>, that is used to override the usual response. Usually, a response is "X is Y", but it can be made "Y" by making the entry "X is <reply> Y".
reply: This is a good way to close junk entries; use "X is <reply>" with nothing after it.
alternation: The | symbol in an entry causes an infobot to choose one of the replies at random. "X is Y|Z" will produce "X is Y" or "X is Z" randomly.
karma: Karma is a community rating system. use "X++" to increase the karma, or "X--" to decrease it. Ask for ratings using "karma for X?"
status: gives current status
shutup: keeps ubu from saying anything, use 'wake up' to go
showmode: ubu reports on addressing mode
|
|
|
#
# User File (c) 1998 Infobot & Associates
#
# FLAGS
# ----------------------
# i Ignored Flag
# f MLF Usage Allowed
# t Teaching Allowed
# r Removing Allowed
# m Modifying Allowed
# c Part/Join Allowed
# s Searching Allowed (possibly computationally expensive)
# S user can make bot Say things
# e Extra Privs [ not implemented robustly: AVOID ]
# p oP on channel by public request
# ----------------------
# o Owner Flag
# ----------------------
#
# recommended default user flags: +trmc
UserEntry default {
flags +trmcs;
}
# here's an example entry
UserEntry oznoid {
name "Kevin A. Lenzo";
title "that guy";
flags +ftrmcsSope;
pass rrmrxB6U4ryRk;
mask *!lenzo@*.speech.cs.cmu.edu;
}
UserEntry plonk {
name "Eep Malloy"
title "that guy II";
flags +trmcspo;
pass rrmrxB6U4ryRk;
mask *!*@*.static.telerama.com
}
|
|
|
#!/usr/bin/perl
my $no_insult;
BEGIN {
eval "use Net::Telnet ();";
$no_insult++ if ($@) ;
}
sub insult {
my $t = new Net::Telnet (Timeout => 3);
$t->Net::Telnet::open(Host => "insulthost.colorado.edu", Port => "1695");
my $line = $t->Net::Telnet::getline(Timeout => 4);
return $line;
}
1;
|
|
|
# infobot :: Kevin Lenzo (c) 1997
use Socket;
use POSIX;
sub I_REAPER
{
$SIG{CHLD} = \&I_REAPER;
$waitedpid = wait;
}
$SIG{CHLD} = \&I_REAPER;
$DOMAIN_CACHE_EXPIRE_TIME = 7*24*60*60;
sub domain_summary
{
# summarize the goo from internic
my $item = $_[0];
my @result;
my $result;
my @dom;
#jaa next 2 lines temp!
@dom = &domain_lookup($item);
return "got it";
if (($DOMAIN_CACHE{$item})
&& ((time()-$DOMAIN_TIME_CACHE{$item}) < $DOMAIN_CACHE_EXPIRE_TIME))
{
return $DOMAIN_CACHE{$item};
}
if (!defined($pid = fork))
{
return "no luck, $safeWho";
}
elsif ($pid)
{
# parent
}
else
{
# child
@dom = &domain_lookup($item);
if ($dom[0] !~ /No match/)
{
foreach (@dom)
{
next if /^\s*$/;
s/:/: /;
s/\s+/ /g;
next if /^\s*Record/;
next if /^\s*Domain Name/;
# next if /^\s*\S+ Contact/;
# last if /^\s*Domain servers/;
last if /^To single out/;
if (s/the internic.*//i)
{
push @result, $_;
last;
}
s/Administrative Contact/Admin/;
s/Technical Contact/Tech/;
s/Domain servers in listed order/DNS/;
push @result, $_;
last if ($#result > 15);
}
foreach (@result)
{
s/\s+/ /; s/^\s+//;
}
foreach (0..$#result-1)
{
$result[$_].="; " unless $result[$_]=~/:\s*$/;
}
$result = join("", @result);
$result =~ s/\s+;/;/g;
$result =~ s/\s+/ /g;
$result =~ s/^.*?Registrant:/Registrant:/;
}
else
{
$result = "I can't find the domain $item";
}
$DOMAIN_TIME_CACHE{$item} = time();
$DOMAIN_CACHE{$item} = $result;
&msg($who, $result);
exit; # exit child.
}
}
sub domain_lookup
{
# do the actual looking up
my($lookup) = @_;
my ($name, $aliases, $proto, $port, $len,
$this, $that, $thisaddr, $thataddr, $hostname);
my @result;
my $whois_server = 'rs.internic.net';
my $whois_port = 43;
$sockaddr = 'S n a4 x8';
chop($hostname = `hostname`);
($name, $aliases, $proto) = getprotobyname('tcp');
($name, $aliases, $whois_port) = getservbyname($whois_port, 'tcp')
unless $whois_port =~ /^\d+$/;
($name, $aliases, $type, $len, $thisaddr) = gethostbyname($hostname);
($name, $aliases, $type, $len, $thataddr) = gethostbyname($whois_server);
$this = pack($sockaddr, AF_INET, 0, $thisaddr);
$that = pack($sockaddr, AF_INET, $whois_port, $thataddr);
socket(DOMAIN_SERVER, PF_INET, SOCK_STREAM, $proto)
|| die "socket: $!";
bind(DOMAIN_SERVER, $this) || die "bind: $!";
connect(DOMAIN_SERVER, $that) || die "connect: $!";
select(DOMAIN_SERVER); $| = 1;
print DOMAIN_SERVER $lookup."\r\n";
@result = ();
my $line;
while (($#result < 30) && ($line = <DOMAIN_SERVER>))
{
push(@result,$line);
}
close(DOMAIN_SERVER); select(STDOUT);
@result;
}
1;
|
|
|
# infobot :: Kevin Lenzo & Patrick Cole (c) 1997
use Socket;
sub srvConnect {
my ($server, $port) = @_;
my ($iaddr, $paddr, $proto);
select(STDOUT);
&status("Connecting to port $port of server $server ...");
$iaddr = inet_aton($server);
$paddr = sockaddr_in($port, $iaddr);
$proto = getprotobyname('tcp');
socket(SOCK, PF_INET, SOCK_STREAM, $proto) or die "socket failed: $!";
$sockaddr = 'S n a4 x8';
if ($param{'vhost_name'}) {
my $hostname = $param{'vhost_name'};
$this = pack($sockaddr, AF_INET, 0, inet_aton($hostname));
&status("trying to bind as $hostname");
bind(SOCK, $this) || die "bind: $!";
}
connect(SOCK, $paddr) or die "connect failed: $!";
&status(" connected.");
}
sub procservmode {
my ($server, $e, $f) = @_;
my @parts = split (/ /, $f);
$cnt=0;
my $mode="";
my $chan="";
foreach (@parts) {
if ($cnt == 0) {
$chan = $_;
} else {
$mode .= $_;
$mode .= " ";
}
++$cnt;
}
chop $mode;
$mode=~s/://;
if ($server eq $chan) {
if ($params{ansi_control}) {
&status(">>> $b$server$ob sets user mode: $b$mode$ob");
} else {
&status(">>> $server sets mode: $mode");
}
} else {
if ($params{ansi_control}) {
&status(">>> $b$server$ob/$b$chan$ob sets server mode: $b$mode$ob");
} else {
&status(">>> $server/$chan sets mode: $mode");
}
}
}
sub procmode {
my ($nick, $user, $host, $e, $f) = @_;
my @parts = split (/ /, $f);
$cnt=0;
my $mode="";
my $chan="";
foreach (@parts) {
if ($cnt == 0) {
$chan = $_;
} else {
$mode .= $_;
$mode .= " ";
}
++$cnt;
}
$mode =~ s/\s$//;
if ($param{ansi_control}) {
&status(">>> mode/$b$chan$ob [$b$mode$ob] by $b$nick$ob");
} else {
&status(">>> mode/$chan [$mode] by $nick");
}
if ($chan =~ /^[\#\&]/) {
my ($modes, $targets) = ($mode =~ /^(\S+)\s+(.*)/);
my @m = ($modes =~ /([+-]*\w)/g);
my @t = split /\s+/, $targets;
if (@m != @t) {
&status("number of modes does not match number of targets: @m / @t");
} else {
my $parity = 0;
foreach (0..$#m) {
if ($m[$_] =~ s/^([-+])//) {
$sign = $1;
if ($sign eq '-') {
$parity = -1;
} else {
$parity = 1;
}
}
if ($parity == 0) {
&status("zero parity mode change... ignored");
} else {
if ($parity > 0) {
$channels{$chan}{$m}{$t} = '+';
} else {
delete $channels{$chan}{$mode}{$t};
}
}
}
}
}
}
sub entryEvt {
my ($nick, $user, $host, $type, $chan) = @_;
if ($type=~/PART/) {
if ($param{ansi_control}) {
&status(">>> $nick ($user\@$host) has left $chan");
} else {
&status(">>> $nick ($user\@$host) has left $chan");
}
} elsif ($type=~/JOIN/) {
if ($netsplit) {
foreach (keys(%snick)) {
if ($nick eq $snick{$_}) {
@be = split (/ /);
if ($param{ansi_control}) {
&status(">>> $b\Netjoined$ob: $be[0] $be[1]");
} else {
&status(">>> $b\Netjoined$ob: $be[0] $be[1]");
}
$netsplit--;
}
}
}
if ($param{ansi_control}) {
&status(">>> $nick ($user\@$host) has joined $chan");
} else {
&status(">>> $nick ($user\@$host) has joined $chan");
}
} elsif ($type=~/QUIT/) {
$chan=~s/\r//;
if ($chan=~/^([\d\w\_\-\/]+\.[\.\d\w\_\-\/]+)\s([\d\w\_\-\/]+\.[\.\d\w\_\-\/]+)$/) {
$i=0;
while (0 and ($i < $netsplit || !$netsplit)) {
# while ($i < $netsplit || !$netsplit) {
$i++;
if (($prevsplit1{$i} ne $2) && ($prevsplit2{$i} ne $1)) {
&status("\Netsplit: $2 split from $1");
$netsplit++;
$prevsplit1{$netsplit} = $2;
$prevsplit2{$netsplit} = $1;
$snick{"$2 $1"}=$nick;
$schan{"$2 $1"}=$chan;
}
}
} else {
if ($param{ansi_control}) {
&status(">>> $b$nick$ob has signed off IRC ($b$chan$ob)");
} else {
&status(">>> $b$nick$ob has signed off IRC ($b$chan$ob)");
}
}
} elsif ($type=~/NICK/) {
if ($param{ansi_control}) {
&status(">>> ".c($nick,'bold green').
" materializes into ".c($chan,'bold green'));
} else {
&status(">>> $b$nick$ob materializes into $b$chan$ob");
}
}
}
sub procevent {
my ($nick, $user, $host, $type, $chan, $msg) = @_;
# support global $nuh, $who
$nuh = "$nick!$user\@$host";
if ($type=~/PRIVMSG/) {
if ($chan =~ /^$ischan/) {
## It's a public message on the channel##
$chan =~ tr/A-Z/a-z/;
if ($msg =~ /\001(.*)\001/ && $msg !~ /ACTION/) {
#### Client To Client Protocol ####
parsectcp($nick, $user, $host, $1, $chan);
} elsif ($msg !~ /ACTION\s(.+)/) {
#### Public Channel Message ####
&IrcMsgHook('public', $chan, $nick, $msg);
} else {
#### Public Action ####
&IrcActionHook($nick, $chan, $1);
}
} else {
## Is Private ##
if ($msg=~/\001(.*)\001/) {
#### Client To Client Protocol ####
parsectcp($nick, $user, $host, $1, $chan);
} else {
#### Is a Private Message ##
&IrcMsgHook('private', $chan, $nick, $msg);
}
}
} elsif ($type=~/NOTICE/) {
if ($chan =~ /^$ischan/) {
$chan =~ tr/A-Z/a-z/;
if ($msg !~ /ACTION (.*)/) {
&status("-$nick/$chan- $msg");
} else {
&status("* $nick/$chan $1");
}
} else {
if ($msg=~/\001([A-Z]*)\s(.*)\001/) {
ctcpReplyParse($nick, $user, $host, $1, $2);
} else {
&status("-$nick($user\@$host)- $msg");
}
}
}
}
sub servmsg {
my $msg=$_[0];
my ($ucount, $uc) = (0, 0);
if ($msg=~/^001/) {
# joinChan(split/\s+/, $param{'join_channels'});
# Line in infobot.config:
# join_channels #chan,key #chan_with_no_key
#
# since , is not allowed in channels, we'll use it to specify keys
# without breaking current join_channels format
for (split /\s+/, $param{'join_channels'}) {
# if it's a keyed chan, replace the comma with a space so it'll
# work as per the RFC (i.e. JOIN #chan key)
s/,/ /;
joinChan ($_);
}
$nicktries=0;
} elsif ($msg=~/^NOTICE ($ident) :(.*)/) {
serverNotice($1,$2);
} elsif ($msg=~/^332 $ident ($ischan) :(.*)/) {
if ($param{ansi_control}) {
&status(">>> topic for $b$1$ob: $2");
} else {
&status(">>> topic for $1: $2");
}
} elsif ($msg=~/^333 $ident $ischan (.*) (.*)$/) {
if ($param{ansi_control}) {
&status(">>> set by $b$1$ob at $b$2$ob");
} else {
&status(">>> set by $1 at $2");
}
} elsif ($msg=~/^433/) {
++$nicktries;
if (length($param{wantNick}) > 9) {
$ident = chop $param{wantNick};
$ident .= $nicktries;
} else {
$ident = $param{wantNick}.$nicktries;
}
if ($param{'opername'}) {
&rawout("OPER $param{opername} $param{operpass}");
}
$param{nick} = $ident;
&status("*** Nickname $param{wantNick} in use, trying $ident");
rawout("NICK $ident");
} elsif ($msg=~/[0-9]+ $ident . ($ischan) :(.*)/) {
my ($chan, $users) = ($1, $2);
&status("NAMES $chan: $users");
my $u;
foreach $u (split /\s+/, $users) {
if (s/\@//) {
$channels{$chan}{o}{$u}++;
}
if (s/\+//) {
$channels{$chan}{v}{$u}++;
}
}
} elsif ($msg=~/[0-9]{3} $ident(\s$ischan)*?\s:(.*)/) {
&status("$2");
}
}
sub serverNotice {
($type, $msg) = @_;
if ($type=~/AUTH/) {
&status("!$param{server}! $msg");
} else {
$msg =~ s/\*\*\* Notice -- //;
&status("-!$param{server}!- $msg");
}
}
sub OperWall {
my ($nick, $msg) = @_;
$msg=~s/\*\*\* Notice -- //;
&status("[wallop($nick)] $msg");
}
sub prockick {
my ($kicker, $chan, $knick, $why) = @_;
if ($param{ansi_control}) {
&status(">>> $b$knick$ob was kicked off $b$chan$ob by $b$kicker$ob ($b$why$ob)");
} else {
&status(">>> $b$knick$ob was kicked off $b$chan$ob by $b$kicker$ob ($b$why$ob)");
}
if ($knick eq $ident) {
&status("SELF attempting to rejoin lost channel $chan");
&joinChan($chan);
}
}
sub prockill {
my ($killer, $knick, $kserv, $killnick, $why) = @_;
if ($knick eq $ident) {
&status("KILLED by $killnick ($why)");
} else {
&status("KILL $knick by $killnick ($why)");
}
}
sub fhbits {
local (@fhlist) = split(' ',$_[0]);
local ($bits);
for (@fhlist) {
vec($bits,fileno($_),1) = 1;
}
$bits;
}
sub irc {
local ($rin, $rout);
local ($buf, $line);
$nicktries=0;
$connected=1;
while ($connected) {
srvConnect($param{server}, $param{port});
if ($param{server_pass}) { # ksiero++
rawout("PASS $param{server_pass}");
}
rawout("NICK $param{wantNick}");
rawout("USER $param{ircuser} $param{ident} $param{server} :$param{realname}");
if ($param{operator}) {
rawout("OPER $param{operName} $param{operPass}\n");
}
$param{nick} = $param{wantNick};
$ident = $param{wantNick};
$/ = "\015" if $^O eq "MacOS";
$rin = fhbits('SOCK');
while (1) {
($nfound,$timeleft) = select($rout=$rin, undef, undef, 0);
if ($rout & SOCK) {
if (sysread(SOCK,$buf,1) <= 0) {
last;
}
if ($buf=~/\n/) {
$line.=$buf;
sparse($line);
undef $line;
} else {
$line.=$buf;
}
}
}
}
}
sub sparse {
$_ = $_[0];
s/\r//;
if (/^PING :(\S+)/) { # Pings are important
rawout("PONG :$1");
&status("SELF replied to server PING") if $param{VERBOSITY} > 2;
} elsif (/^:\S+ ([\d]{3} .*)/) {
servmsg($1);
} elsif (/^:([\d\w\_\-\/]+\.[\.\d\w\_\-\/]+) NOTICE ($ident) :(.*)/) {
&status("\-\[$1\]- $3");
} elsif (/^NOTICE (.*) :(.*)/) {
serverNotice($1, $2);
} elsif (/^:(.*)!(.*)@(.*?)\s(PRIVMSG|NOTICE)\s([\#\&]?.*?)\s:(.*)/) {
procevent($1,$2,$3,$4,$5,$6);
} elsif (/^:(.*)!(.*)@(.*?) (PART|JOIN|NICK|QUIT) :?(.*)/) {
entryEvt($1,$2,$3,$4,$5);
} elsif (/^:(.*) WALLOPS :(.*)/) {
OperWall($1,$2);
} elsif (/^:(.*)!(.*)@(.*) (MODE) (.*)/) {
procmode($1,$2,$3,$4,$5);
} elsif (/^:(.*) (MODE) (.*)/) {
procservmode($1,$2,$3);
} elsif (/^:(.*)!.*@.* KICK ((\#|&).+) (.*) :(.*)/) {
prockick($1,$2,$4,$5);
} elsif (/^ERROR :(.*)/) {
&status("ERROR $1");
} elsif (/^:(.*)!.*@.* TOPIC (\#.+) :(.*)/) {
if ($param{ansi_control}) {
&status(">>> $1$b\[$ob$2$b\]$ob set the topic: $3");
} else {
&status(">>> $1[$2] set the topic: $3");
}
} elsif (/^:(.*)!.*@.* KILL (.*) :(.*)!(.*) \((.*)\)/) {
prockill($1,$2,$3,$4,$5);
} else {
&status("UNKNOWN $_");
}
}
1;
|
|
|
# infobot :: Kevin Lenzo & Patrick Cole (c) 1997
use Socket;
$| = 1;
$SIG{'INT'} = 'killed';
$SIG{'KILL'} = 'killed';
$SIG{'TERM'} = 'killed';
$VER_MAJ = 0;
$VER_MIN = 44;
$VER_MOD = "2";
$version = "infobot $VER_MAJ\.$VER_MIN\.$VER_MOD [oznoid]";
$updateCount = 0;
$questionCount = 0;
$autorecon = 0;
$label = "(?:[a-zA-Z\d](?:(?:[a-zA-Z\d\-]+)?[a-zA-Z\d])?)";
$dmatch = "(?:(?:$label\.?)*$label)";
$ipmatch = "\d+\.\d+\.\d+\.\d";
$ischan = "[\#\&].*?";
$isnick = "[a-zA-Z]{1}[a-zA-Z0-9\_\-]+";
sub TimerAlarm {
&status("$TimerWho's timer ended. sending wakeup");
&say("$TimerWho: this is your wake up call, foobar.");
}
sub killed {
my $quitMsg = $param{'quitMsg'} || "regrouping";
&quit($quitMsg);
&closeDBM("is", "are");
exit(1);
}
sub joinChan {
foreach (@_) {
&status("joined $_");
rawout("JOIN $_");
}
}
sub invite {
my($who, $chan) = @_;
rawout("INVITE $who $chan");
}
sub notice {
my($who, $msg) = @_;
foreach (split(/\n/, $msg)) {
rawout("NOTICE $who :$_");
}
}
sub say {
my $msg=$_[0];
&status("</$talkchannel> $msg");
rawout("PRIVMSG $talkchannel :$msg");
}
sub msg {
my ($nick, $msg) = @_;
&status(">$nick< $msg");
rawout("PRIVMSG $nick :$msg");
}
sub quit {
my $quitmsg = $_[0];
rawout("QUIT :$quitmsg");
&status("QUIT $param{nick} has quit IRC ($quitmsg)");
close(SOCK);
}
sub nick {
$nick = $_[0];
rawout("NICK ".$nick);
}
sub part {
foreach (@_) {
status("left $_");
rawout("PART $_");
delete $channels{$_};
}
}
sub mode {
my ($chan, @modes) = @_;
my $modes = join(" ", @modes);
rawout("MODE $chan $modes");
}
sub op {
my ($chan, $arg) = @_;
$arg =~ s/^\s+//;
$arg =~ s/\s+$//;
$arg =~ s/\s+/ /;
my @parts = split(/\s+/, $arg);
my $os = "o" x scalar(@parts);
mode($chan, "+$os $arg");
}
sub deop {
my ($chan, $arg) = @_;
$arg =~ s/^\s+//;
$arg =~ s/\s+$//;
$arg =~ s/\s+/ /;
my @parts = split(/\s+/, $arg);
my $os = "o" x scalar(@parts);
&mode($chan, "-$os $arg");
}
sub timer {
($t, $timerStuff) = @_;
# alarm($t);
}
$SIG{"ALRM"} = \&doTimer;
sub doTimer {
rawout($timerStuff);
}
sub channel {
if (scalar(@_) > 0) {
$talkchannel = $_[0];
}
$talkchannel;
}
sub rawout {
$buf = $_[0];
$buf =~ s/\n//gi;
select(SOCK); $| = 1;
print SOCK "$buf\n";
select(STDOUT);
}
1;
|
|
|
# infobot :: Kevin Lenzo (c) 1997
# Tidied up ?
sub IrcActionHook {
my ($who, $channel, $message) = @_;
&channel($channel);
&process($who, 'public action', $message);
if ($msgType =~ /public/) {
&status("<$who/$channel> $origMessage");
} else {
&status("[$who] $origMessage");
}
}
sub IrcMsgHook {
my ($type, $channel, $who, $message) = @_;
if ($type =~ /public/i) {
&channel($channel);
&process($who, $type, $message);
&status("<$who/$channel> $origMessage");
}
if ($type =~ /private/i) {
if (($params{'mode'} eq 'IRC') && ($who eq $prevwho)) {
$delay = time() - $prevtime;
$prevcount++;
if (0 and $delay < 1) {
# this is where to put people on ignore if they flood you
if (IsFlag("o") ne "o") {
&msg($who, "You will be ignored -- flood detected.");
$ignoreList{$who}++;
&log_line("ignoring ".$who);
return;
}
}
return if (($message eq $prevmsg) && ($delay < 10));
} else {
$prevcount = 0;
$firsttime = time;
}
$prevtime = time unless ($message eq $prevmsg);
$prevmsg = $message;
$prevwho = $who;
&process($who, $type, $message);
&status("[$who] $origMessage");
}
return;
}
sub hook_dcc_request {
my($type, $text) = @_;
if ($type =~ /chat/i) {
&status("received dcc chat request from $who : $text");
my($locWho) = $who;
$locWho =~ tr/A-Z/a-z/;
$locWho =~ s/\W//;
&docommand("dcc chat ".$who);
&msg('='.$who, "Hello, ".$who);
}
return '';
}
sub hook_dcc_chat {
my($locWho, $message)=@_;
$msgType = "dcc_chat";
my($saveWho) = $who;
$who = "=".$who;
&process($who, $msgType, $message);
$who = $saveWho;
return '';
}
1;
|
|
|
perl update_db ..\prefabfacts\html.txt ..\ubu\ubu-is
perl update_db ..\prefabfacts\airport.txt ..\ubu\ubu-is
perl update_db ..\prefabfacts\areacodes.txt ..\ubu\ubu-is
perl update_db ..\prefabfacts\html.txt ..\ubu\ubu-is
perl update_db ..\prefabfacts\techdict.txt ..\ubu\ubu-is
perl update_db ..\prefabfacts\country_net_codes.fact ..\ubu\ubu-is
perl update_db ..\prefabfacts\old_test_meanings.fact ..\ubu\ubu-is
perl update_db ..\prefabfacts\peri_abb_and_num.fact ..\ubu\ubu-is
perl update_db ..\prefabfacts\ports.fact ..\ubu\ubu-is
perl update_db ..\prefabfacts\reverseports.fact ..\ubu\ubu-is
perl update_db ..\prefabfacts\rfc_index.fact ..\ubu\ubu-is
perl update_db ..\prefabfacts\rx_codes.fact ..\ubu\ubu-is
perl update_db ..\prefabfacts\security.fact ..\ubu\ubu-is
|
|
|
#!/usr/bin/perl
$| = 1;
print "plaintext> ";
while (<>) {
chomp;
$result = &mkpasswd($_);
print "\t$result\n";
print "plaintext> ";
}
sub mkpasswd {
my $what = $_[0];
my $salt = chr(65+rand(27)).chr(65+rand(27));
$salt =~ s/\W/x/g;
return crypt($what, $salt);
}
|
|
|
# infobot copyright (C) kevin lenzo 1997-98
if (!defined(%digits)) {
%digits = (
"first", "1",
"second", "2",
"third", "3",
"fourth", "4",
"fifth", "5",
"sixth", "6",
"seventh", "7",
"eighth", "8",
"ninth", "9",
"tenth", "10",
"one", "1",
"two", "2",
"three", "3",
"four", "4",
"five", "5",
"six", "6",
"seven", "7",
"eight", "8",
"nine", "9",
"ten", "10"
);
}
foreach $x (keys %digits) {
$in =~ s/\b$x\b/$digits{$x}/g;
}
sub math {
# Math handling.
if ($param{'fortranMath'}) {
if ($in =~ /^calc\s+(.+)$/) {
$parm = $1;
$parm =~ s/\s//g;
#$parm =~ s/[a-zA-Z]//g;
status("bc: $parm");
open(P, "echo $parm|bc 2>&1 |");
$tmp = '';
@prevs = ();
foreach $line (<P>) {
chomp $line;
$line =~ s/\\$//;
$line =~ s/\(standard_in\) 1: /$who: /;
$tmp = 0;
foreach $p (@prevs) {
if ($p eq $line) {
$tmp = 1;
}
}
if ($tmp == 0 && $line !~ /illegal character/) {
performReply($line);
}
push(@prevs, $line);
}
close(P);
return '';
}
}
if ($param{'perlMath'}) {
if (!$lhs and ($in !~ /^\s*$/) and ($in !~ /(\d+\.){2,}/)) {
my($locMsg) = $in;
foreach (keys %digits) {
$locMsg =~ s/$_/$digits{$_}/g;
}
while ($locMsg =~ /(exp ([\w\d]+))/) {
$exp = $1;
$val = exp($2);
$locMsg =~ s/$exp/+$val/g;
}
while ($locMsg =~ /(hex2dec\s*([0-9A-Fa-f]+))/) {
$exp = $1;
$val = hex($2);
$locMsg =~ s/$exp/+$val/g;
}
if ($locMsg =~ /^\s*(dec2hex\s*(\d+))\s*\?*/) {
$exp = $1;
$val = sprintf("%x", "$2");
$locMsg =~ s/$exp/+$val/g;
}
$e = exp(1);
$locMsg =~ s/\be\b/$e/;
while ($locMsg =~ /(log\s*((\d+\.?\d*)|\d*\.?\d+))\s*/) {
$exp = $1;
$res = $2;
if ($res == 0) { $val = "Infinity";}
else { $val = log($res); } ;
$locMsg =~ s/$exp/+$val/g;
}
while ($locMsg =~ /(bin2dec ([01]+))/) {
$exp = $1;
$val = join ("", unpack ("B*", $2)) ;
$locMsg =~ s/$exp/+$val/g;
}
while ($locMsg =~ /(dec2bin (\d+))/) {
$exp = $1;
$val = join('', unpack('B*', pack('N', $2)));
$val =~ s/^0+//;
$locMsg =~ s/$exp/+$val/g;
}
$locMsg =~ s/ to the / ** /g;
$locMsg =~ s/\btimes\b/\*/g;
$locMsg =~ s/\bdiv(ided by)? /\/ /g;
$locMsg =~ s/\bover /\/ /g;
$locMsg =~ s/\bsquared/\*\*2 /g;
$locMsg =~ s/\bcubed/\*\*3 /g;
$locMsg =~ s/\bto\s+(\d+)(r?st|nd|rd|th)?( power)?/\*\*$1 /ig;
$locMsg =~ s/\bpercent of/*0.01*/ig;
$locMsg =~ s/\bpercent/*0.01/ig;
$locMsg =~ s/\% of\b/*0.01*/g;
$locMsg =~ s/\%/*0.01/g;
$locMsg =~ s/\bsquare root of (\d+)/$1 ** 0.5 /ig;
$locMsg =~ s/\bcubed? root of (\d+)/$1 **(1.0\/3.0) /ig;
$locMsg =~ s/ of / * /;
$locMsg =~ s/(bit(-| )?)?xor(\'?e?d( with))?/\^/g;
$locMsg =~ s/(bit(-| )?)?or(\'?e?d( with))?/\|/g;
$locMsg =~ s/bit(-| )?and(\'?e?d( with))?/\& /g;
$locMsg =~ s/(plus|and)/+/ig;
if (($locMsg =~ /^\s*[-\d*+\s()\/^\.\|\&\*\!]+\s*$/)
&& ($locMsg !~ /^\s*\(?\d+\.?\d*\)?\s*$/)
&& ($locMsg !~ /^\s*$/)
&& ($locMsg !~ /^\s*[( )]+\s*$/))
{
# $tmpMsg = $locMsg;
$locMsg = eval($locMsg);
if ($locMsg =~ /^[-+\de\.]+$/) {
$locMsg = sprintf("%1.12f", $locMsg);
$locMsg =~ s/\.?0+$//;
$locMsg =~ s/(\.\d+)000\d+/$1/;
$lhs = $locMsg;
if (length($locMsg) > 30) {
$lhs = "a number with quite a few digits...";
}
} else {
$lhs = "";
}
}
}
}
$locMsg;
}
1;
|
|
|
#
# metar -- infobot module for METAR Aviation Routine Weather Report
# based roughly on example script from Geo::METAR.
#
# hacked up by Rich Lafferty (mendel) <mendel@pobox.com>.
#
# minor mods by kevin lenzo (oznoid) <lenzo@cs.cmu.edu>
# -- package, BEGIN, eval checks
# added status line if LWP isn't there 02-aug-99
# minor mod by Lazarus Long <lazarus@frontiernet.net>
# due to "http://tcsv5.nws.noaa.gov/cgi-bin/mgetmetar.pl?cccc="
# no longer working.
package metar;
my $no_metar;
BEGIN {
eval "use Geo::METAR";
if ($@) { $no_metar++};
eval "use LWP::UserAgent";
if ($@) { $no_metar++};
}
sub metar::get {
my $line = shift;
return '' unless $line =~ /^metar (.*)/;
if ($no_metar) {
&status("METAR function requires LWP::UserAgent and Geo::METAR");
return '';
}
my $site_id = uc($1);
if ($site_id !~ /^[A-Z]{4,5}$/) {
return "that doesn't look like a valid METAR code";
}
# METAR web-resource.
my $metar_url = "http://weather.noaa.gov/cgi-bin/mgetmetar.pl?cccc=";
# Grab METAR report from Web.
my $agent = new LWP::UserAgent;
my $grab = new HTTP::Request GET => $metar_url . $site_id;
my $reply = $agent->request($grab);
# If it can't find it, assume luser error :-)
if (!$reply->is_success) {
return "$site_id doesn't seem to exist; try a 4-letter station code (like KAGC)";
}
# extract METAR from incredibly and painfully verbose webpage
my $webdata = $reply->as_string;
$webdata =~ m/($site_id\s\d+Z.*?)</s;
my $metar = $1;
# Sane?
return "Data for $site_id not available, try later." if length($metar) < 10;
# Process raw METAR data
my $report = new Geo::METAR;
$report->debug(0);
$report->metar($metar);
# Generate response. Messy as hell, but it works. :-)
# Don't rely on Geo::METAR docs for variable names. It's not
# even close in some cases.
#
# oh, and talk about annoying:
# } elsif ($tok =~ /K[A-Z]{3,3}/) {
# $self->{site} = $tok;
# the WORLD is NOT the UNITED STATES. We can't rely on $foo->{site},
# since it only grabs American (K-prefix) SITE_IDs.
my $response = "$report->{TYPE} ";
$response .= "($report->{MOD}) " if $report->MOD;
$response .= "for $site_id at $report->{DATE} $report->{TIME}: Winds $report->{WIND_KTS} ";
$response .= "to $report->{WIND_KTS_GUST} " if $report->WIND_KTS_GUST;
$response .= "at $report->{WIND_DIR_DEG} ($report->{WIND_DIR_ENG}). Temp $report->{C_TEMP}C/$report->{F_TEMP}F and dewpoint $report->{C_DEW}C/$report->{F_DEW}F. Visibility $report->{visibility}. Weather conditions ";
$response .= join(' ', @{$report->{weather}}) ? join(' ', @{$report->{weather}}) : "not available"; # Most METAR puts this in 'conditions' ({sky}).
$response .= ". Altimeter ";
$response .= $report->{alt} ? "$report->{alt}. " : "not available. ";
$response .= "Cloud ";
$response .= join(' ', @{$report->{sky}});
$response .= ". Have a nice flight."; # :-)
return $response;
}
1;
|
|
|
# infobot :: Kevin Lenzo & Patrick Cole (c) 1997
use Socket;
# send info to devnull
sub devnull
{
return '';
}
# ask frendly bots
sub askFriendlyBots
{
my $request = $_[0];
return if ($request =~ /^no\,?\s+/);
foreach $bot (split /\s+/, $param{'friendlyBots'})
{
$request =~ s/^(is|are) //i;
&msg($bot, ":INFOBOT:QUERY <$who> $request");
}
}
# format a public message
sub FormatText
{
my($nick, $msg) = @_;
undef @ret;
undef %str;
my $msgLen = length($msg);
my $nickLen = length($nick);
my $tot = 0;
my $cnt = 0;
foreach (split //, $msg)
{
if ($cnt == (80 - $nickLen - 3))
{
$tot++;
$cnt=0;
}
$str{$tot} .= $_;
$cnt++;
}
foreach (keys %str)
{
push(@ret, $str{$_}."\n");
}
return @ret;
}
sub status
{
$statcount++;
my($input) = @_;
if ($param{'VERBOSITY'} > 0)
{
if ($param{ansi_control})
{
printf $_green."[%5d] ".$ob, $statcount;
$input =~ s/[\cA-\c_]//ig; # (Derek Moeller)++
my $printable = $input;
if ($printable =~ s/^(<\/\S+>) //)
{
# it's me saying something on a channel
my $name = $1;
print "$b_yellow$name $printable$ob\n";
}
elsif ($printable =~ s/^(<\S+>) //)
{
my $name = $1;
if ($addressed)
{
print "$b_red$name $printable$ob\n";
}
else
{
print "$b_cyan$name$ob $printable\n";
}
}
elsif ($printable =~ s/^(-\S+-) //)
{
# notice
print "$_green$1 $printable$ob\n";
}
elsif ($printable =~ s/^(\[\S+\]) //)
{
# message from someone
print "$b_red$1 $printable$ob\n";
}
elsif ($printable =~ s/^(>\S+<) //)
{
# i'm messaging someone
print "$b_magenta$1 $printable$ob\n";
}
elsif ($printable =~ s/^(!\S+!) //)
{
# i'm messaging someone
print "$_red$1 $printable$ob\n";
}
elsif ($printable =~ s/^(enter:|update:|forget:) //)
{
# something that should be SEEN
print "$b_green$1 $printable$ob\n";
}
else
{
print "$printable\n";
}
}
else
{
printf ("[%5d] $input\n", $statcount) if ($input !~ /^\s*$/);
}
}
&log_line("[$statcount] ".$input);
}
sub saveState
{
++$stateinc;
&closeDBM;
&openDBM;
$changes = 0;
return 1;
}
sub performSay
{
my($in) = @_;
if (!defined($prevIn))
{
$prevIn = "";
};
if (($skipReply == 0) && ($in !~ 'NOREPLY'))
{
$prevIn = $in;
if (0)
{
# for mac speech manager niceties
$in =~ s/ at (ht|f)/ $1/ig;
$in =~ s/((ht|f)tp:\S+)/here [[cmnt $1 ]]/ig;
}
&say($in);
}
# this could echo everything to somewhere
# &msg('somebody', ".say $in");
return '';
}
sub performReply
{
if ($msgType eq 'private')
{
&msg($who, $_[0]);
}
else
{
&say("$_[0]");
}
}
sub log_line
{
my($line) = @_;
my($logwrite) = 0;
my $s = time();
if ($param{'logfile'} ne '')
{
$line =~ s/\n*$/\n/;
open(TRACK, ">>$param{logfile}");
$loglines++;
$total_loglines++;
print TRACK "$s $line";
close(TRACK); # if (TRACK);
}
}
sub getAllKeys
{
@myIsKeys = getDBMKeys("is");
@myAreKeys = getDBMKeys("are");
$factoidCount = $#myIsKeys + $#myAreKeys + 2;
$updateCount = 0;
}
sub purifyNick
{
my $safeWho = $_[0];
$safeWho =~ s/\*//g;
$safeWho =~ s/\\/\\\\/g;
$safeWho =~ s/\[/\\\[/g;
$safeWho =~ s/\]/\\\]/g;
$safeWho =~ s/\|/\\\|/g;
$safeWho =~ tr/A-Z/a-z/;
$safeWho = substr($safeWho, 0, 9);
$safeWho =~ s/\s+.*//;
return $safeWho;
}
1;
__DATA__
/dimer\[0\/: trailing \ in regexp at /usr/users/infobot/infobot-current/src/Misc.pl line 164, <FH> chunk 98.
|
|
|
# Infobot user extension stubs
# Kevin A. Lenzo
# put your routines in here.
do 'src/nickometer.pl'; # Adam Spier's "lame nick-o-meter" code
sub myRoutines
{
# called after it decides if it's been addressed.
# you have access tothe global variables here,
# which is bad, but anyway.
# you can return 'NOREPLY' if you want to stop
# processing past this point but don't want
# an answer. if you don't return NOREPLY, it
# will let all the rest of the default processing
# go to it. think of it as 'catching' the event.
# $addressed is whether the infobot has been
# named or, if a private or standalone
# context, addressed is always 'true'
# $msgType can be 'public', 'private', maybe 'dcc_chat'
# $who is the sender of the message
# $message is the current state of the input, after
# the addressing stuff stripped off the name
# $origMessage is the text of the original message before
# any normalization or processing
# you have access to all the routines in urlIrc.pl too,
# of course.
# example:
if ($addressed)
{
# only if the infobot is addressed
if ($message =~ /how (the hell )?are (ya|you)( doin\'?g?)?\?*$/)
{
sayIt($msgType, $who, $howAreYa[rand($#howAreYa)]);
return 'NOREPLY';
}
}
else
{
# we haven't been addressed, but we are still listening
}
# from Chris Tessone: slashdot headlines
# "slashdot" or "slashdot headlines"
if (defined($param{'slash'}) and $message =~ /^\s*slashdot( headlines)?\W*\s*$/)
{
my $headlines = &getslashdotheads();
sayIt($msgType, $who, $headlines);
return "NOREPLY";
}
# Jonathan Feinberg's babel-bot -- jdf++
if (defined $param{babel} && (1 or $addressed) &&
$message =~ m/
^\s*
(?:babel(?:fish)?|x|xlate|translate)
\s+
(to|from) # direction of translation (through)
\s+
($babel::lang_regex)\w* # which language?
\s*
(.+) # The phrase to be translated
/xoi)
{
my $whom = $who; # building a closure, need lexical
my $callback = $msgType eq 'public' ?
sub
{
say("$who: $_[0]")
}
:
sub
{
msg($who, $_[0])
}
;
&babel::forking_babelfish(lc $1, lc $2, $3, $callback);
return 'NOREPLY';
}
# insult server. patch thanks to michael@limit.org
if ($param{'insult'} and ($message =~ /^\s*insult (.*)\s*$/))
{
my $person = $1;
my $language = "english";
if ($person =~ s/ in \s*($babel::lang_regex)\w*\s*$//xi)
{
$language = lc($1);
}
$person = $who if $person =~ /^\s*me\s*$/i;
my $insult = &insult();
if ($person ne $who)
{
$insult =~ s/^\s*You are/$person is/i;
}
if ($insult =~ /\S/)
{
if ($param{'babel'} and ($language ne "english"))
{
my $whom = $who; # building a closure, need lexical
my $callback = $msgType eq 'public' ?
sub
{
say("$_[0]")
}
:
sub
{
msg($whom, $_[0])
}
;
&babel::forking_babelfish("to", $language, $insult, $callback);
return 'NOREPLY';
}
}
else
{
$insult = "No luck, $who";
}
sayIt($msgType, $who, $insult);
return "NOREPLY";
}
if ($param{'weather'} and ($message =~ /^\s*weather\s+(?:for\s+)?(.*?)\s*\?*\s*$/))
{
my $code = $1;
my $weath ;
if ($code =~ /^[a-zA-Z][a-zA-Z0-9]{3,4}$/)
{
$weath = &Weather::NOAA::get($code);
}
else
{
$weath = "Try a 4-letter station code (see http://weather.noaa.gov/weather/curcond.html for locations and codes)";
}
&msg($who, $weath);
return 'NOREPLY';
}
if (defined $param{'metar'})
{
my $metar = &metar::get($message);
if ($metar)
{
&msg($who, $metar);
return 'NOREPLY';
}
}
if (defined $param{'uaflight'})
{
if ($message =~ /usair\s+flight\s+(\d+)/i)
{
my $res = &UAFlight::get_ua_flight_status($1);
if ($res)
{
sayIt($msgType, $who, $res);
return 'NOREPLY';
}
}
}
# from Simon: google searching
# modified to fork and generally search by oznoid
if (defined($param{'wwwsearch'}) and $message =~ /^\s*(?:search\s+)?($W3Search::regex)\s+for\s+['"]?(.*?)['"]?\s*\?*\s*$/i )
{
my $callback = $msgType eq 'public' ?
sub
{
say("$who: $_[0]")
}
:
sub
{
msg($who, $_[0])
}
;
&W3Search::forking_W3Search($1,$2,$param{'wwwsearch'}, $callback);
return "NOREPLY";
}
# Adam Spiers nickometer
if ($message =~ /^\s*(?:lame|nick)-?o-?meter(?: for)? (\S+)/i)
{
my $term = $1;
$term = $who if (lc($term) eq 'me');
$term =~ s/\?+\s*//;
my $percentage = &nickometer($term);
if ($percentage =~ /NaN/)
{
$percentage = "off the scale";
}
else
{
$percentage = sprintf("%0.4f", $percentage);
$percentage =~ s/\.?0+$//;
$percentage .= '%';
}
sayIt($msgType, $who, "'$term' is $percentage lame");
return 'NOREPLY';
}
if ($message =~ /^foldoc(?: for)?\s+(.*)/i)
{
my ($terms) = $1;
$terms =~ s/\?\W*$//;
my $key= $terms;
$key =~ s/\s+$//;
$key =~ s/^\s+//;
$key =~ s/\W+/+/g;
my $reply = "$terms may be sought in foldoc at http://wombat.doc.ic.ac.uk/foldoc/foldoc.cgi?query=$key";
sayIt($msgType, $who, $reply);
return 'NOREPLY';
}
if ($message =~ /^(?:quote|stock price)(?: of| for)? ([A-Z]{1,6})\?*$/)
{
my $reply = "stock quotes for $1 may be sought at http://quote.yahoo.com/q?s=$1\&d=v1";
sayIt($msgType, $who, $reply);
return 'NOREPLY';
}
if ($message =~ /^rot13\s+(.*)/i)
{
# rot13 it
my $reply = $1;
$reply =~ y/A-Za-z/N-ZA-Mn-za-m/;
sayIt($msgType, $who, $reply);
return 'NOREPLY';
}
return ''; # do nothing and let the other routines have a go
}
@howAreYa = ("just great", "peachy", "mas o menos", "great! you",
"like a million bucks", "so-so", "I've got a cold",
"you know how it is", "eh, ok", "pretty good. how about you");
1;
|
|
|
#!/usr/bin/perl -w
#
# Lame-o-Nickometer backend
#
# (c) 1998 Adam Spiers <adam.spiers@new.ox.ac.uk>
#
# You may do whatever you want with this code, but give me credit.
#
# $Id: nickometer.pl,v 1.3 1998/09/05 19:58:15 adam Exp $
#
use strict;
use Getopt::Std;
use Math::Trig;
use vars qw($VERSION $score $verbose);
$VERSION = '$Revision: 1.3 $'; # '
$VERSION =~ s/^.*?([\d.]+).*?$/$1/;
sub nickometer ($) {
local $_ = shift;
local $score = 0;
# Deal with special cases (precede with \ to prevent de-k3wlt0k)
my %special_cost = (
'69' => 500,
'dea?th' => 500,
'dark' => 400,
'n[i1]ght' => 300,
'n[i1]te' => 500,
'fuck' => 500,
'sh[i1]t' => 500,
'coo[l1]' => 500,
'kew[l1]' => 500,
'lame' => 500,
'dood' => 500,
'dude' => 500,
'[l1](oo?|u)[sz]er' => 500,
'[l1]eet' => 500,
'e[l1]ite' => 500,
'[l1]ord' => 500,
'pron' => 1000,
'warez' => 1000,
'xx' => 100,
'\[rkx]0' => 1000,
'\0[rkx]' => 1000,
);
foreach my $special (keys %special_cost) {
my $special_pattern = $special;
my $raw = ($special_pattern =~ s/^\\//);
my $nick = $_;
unless ($raw) {
$nick =~ tr/023457+8/ozeasttb/;
}
&punish($special_cost{$special}, "matched special case /$special_pattern/")
if $nick =~ /$special_pattern/i;
}
# Allow Perl referencing
s/^\\([A-Za-z])/$1/;
# Keep me safe from Pudge ;-)
s/\^(pudge)/$1/i;
# C-- ain't so bad either
s/^C--$/C/;
# Punish consecutive non-alphas
s/([^A-Za-z0-9]{2,})
/my $consecutive = length($1);
&punish(&slow_pow(10, $consecutive),
"$consecutive total consecutive non-alphas")
if $consecutive;
$1
/egx;
# Remove balanced brackets and punish for unmatched
while (s/^([^()]*) (\() (.*) (\)) ([^()]*) $/$1$3$5/x ||
s/^([^{}]*) (\{) (.*) (\}) ([^{}]*) $/$1$3$5/x ||
s/^([^\[\]]*) (\[) (.*) (\]) ([^\[\]]*) $/$1$3$5/x)
{
print "Removed $2$4 outside parentheses; nick now $_\n" if $verbose;
}
my $parentheses = tr/(){}[]/(){}[]/;
&punish(&slow_pow(10, $parentheses),
"$parentheses unmatched " .
($parentheses == 1 ? 'parenthesis' : 'parentheses'))
if $parentheses;
# Punish k3wlt0k
my @k3wlt0k_weights = (5, 5, 2, 5, 2, 3, 1, 2, 2, 2);
for my $digit (0 .. 9) {
my $occurrences = s/$digit/$digit/g || 0;
&punish($k3wlt0k_weights[$digit] * $occurrences * 30,
$occurrences . ' ' .
(($occurrences == 1) ? 'occurrence' : 'occurrences') .
" of $digit")
if $occurrences;
}
# An alpha caps is not lame in middle or at end, provided the first
# alpha is caps.
my $orig_case = $_;
s/^([^A-Za-z]*[A-Z].*[a-z].*?)[_-]?([A-Z])/$1\l$2/;
# A caps first alpha is sometimes not lame
s/^([^A-Za-z]*)([A-Z])([a-z])/$1\l$2$3/;
# Punish uppercase to lowercase shifts and vice-versa, modulo
# exceptions above
my $case_shifts = &case_shifts($orig_case);
&punish(&slow_pow(9, $case_shifts),
$case_shifts . ' case ' .
(($case_shifts == 1) ? 'shift' : 'shifts'))
if ($case_shifts > 1 && /[A-Z]/);
# Punish lame endings (TorgoX, WraithX et al. might kill me for this :-)
&punish(50, 'last alpha lame') if $orig_case =~ /[XZ][^a-zA-Z]*$/;
# Punish letter to numeric shifts and vice-versa
my $number_shifts = &number_shifts($_);
&punish(&slow_pow(9, $number_shifts),
$number_shifts . ' letter/number ' .
(($number_shifts == 1) ? 'shift' : 'shifts'))
if $number_shifts > 1;
# Punish extraneous caps
my $caps = tr/A-Z/A-Z/;
&punish(&slow_pow(7, $caps), "$caps extraneous caps") if $caps;
# Now punish anything that's left
my $remains = $_;
$remains =~ tr/a-zA-Z0-9//d;
my $remains_length = length($remains);
&punish(50 * $remains_length + &slow_pow(9, $remains_length),
$remains_length . ' extraneous ' .
(($remains_length == 1) ? 'symbol' : 'symbols'))
if $remains;
print "\nRaw lameness score is $score\n" if $verbose;
# Use an appropriate function to map [0, +inf) to [0, 100)
my $percentage = 100 *
(1 + tanh(($score-400)/400)) *
(1 - 1/(1+$score/5)) / 2;
my $digits = 2 * (2 - &round_up(log(100 - $percentage) / log(10)));
return sprintf "%.${digits}f", $percentage;
}
sub case_shifts ($) {
# This is a neat trick suggested by freeside. Thanks freeside!
my $shifts = shift;
$shifts =~ tr/A-Za-z//cd;
$shifts =~ tr/A-Z/U/s;
$shifts =~ tr/a-z/l/s;
return length($shifts) - 1;
}
sub number_shifts ($) {
my $shifts = shift;
$shifts =~ tr/A-Za-z0-9//cd;
$shifts =~ tr/A-Za-z/l/s;
$shifts =~ tr/0-9/n/s;
return length($shifts) - 1;
}
sub slow_pow ($$) {
my ($x, $y) = @_;
return $x ** &slow_exponent($y);
}
sub slow_exponent ($) {
my $x = shift;
return 1.3 * $x * (1 - atan($x/6) *2/pi);
}
sub round_up ($) {
my $float = shift;
return int($float) + ((int($float) == $float) ? 0 : 1);
}
sub punish ($$) {
my ($damage, $reason) = @_;
return unless $damage;
$score += $damage;
print "$damage lameness points awarded: $reason\n" if $verbose;
}
1;
|
|
|
#!/usr/bin/perl
package Weather;
# kevin lenzo (C) 1999 -- get the weather forcast NOAA.
# feel free to use, copy, cut up, and modify, but if
# you do something cool with it, let me know.
my $no_weather;
my $cache_time = 60 * 40 ; # 40 minute cache time
my $default = 'KAGC';
BEGIN {
$no_weather = 0;
eval "use LWP::Simple";
$no_weather++ if ($@);
}
sub Weather::NOAA::get {
my ($station) = shift;
$station = uc($station);
my $result;
if ($no_weather) {
return 0;
} else {
if (exists $cache{$station}) {
my ($time, $response) = split $; , $cache{$station};
if ((time() - $time) < $cache_time) {
return $response;
}
}
my $content = LWP::Simple::get("http://tgsv7.nws.noaa.gov/weather/current/$station.html");
if ($content =~ /ERROR/i) {
return "I can't find that station code (see http://weather.noaa.gov/weather/curcond.html for locations codes)";
}
$content =~ s|.*?current weather conditions.*?</TR>||is;
$content =~ s|.*?<TR>(?:\s*<[^>]+>)*\s*([^<]+)\s<.*?</TR>||is;
my $place = $1;
chomp $place;
$content =~ s|.*?<TR>(?:\s*<[^>]+>)*\s*([^<]+)\s<.*?</TR>||is;
my $id = $1;
chomp $id;
$content =~ s|.*?conditions at.*?</TD>||is;
$content =~ s|.*?<OPTION SELECTED>\s+([^<]+)\s<OPTION>.*?</TR>||s;
my $time = $1;
$time =~ s/-//g;
$time =~ s/\s+/ /g;
$content =~ s|\s(.*?)<TD COLSPAN=2>||s;
my $features = $1;
while ($features =~ s|.*?<TD ALIGN[^>]*>(?:\s*<[^>]+>)*\s+([^<]+?)\s+<.*?<TD>(?:\s*<[^>]+>)*\s+([^<]+?)\s<.*?/TD>||s) {
my ($f,$v) = ($1, $2);
chomp $f; chomp $v;
$feat{$f} = $v;
}
$content =~ s|.*?>(\d+\S+\s+\(\S+\)).*?</TD>||s; # max temp;
$max_temp = $1;
$content =~ s|.*?>(\d+\S+\s+\(\S+\)).*?</TD>||s;
$min_temp = $1;
if ($time) {
$result = "$place; $id; last updated: $time";
foreach (sort keys %feat) {
next if $_ eq 'ob';
$result .= "; $_: $feat{$_}";
}
my $t = time();
$cache{$station} = join $;, $t, $result;
} else {
$result = "I can't find that station code (see http://weather.noaa.gov/weather/curcond.html for locations and codes)";
}
return $result;
}
}
if (0) {
if (-t STDIN) {
my $result = Weather::NOAA::get($default);
$result =~ s/; /\n/g;
print "\n$result\n\n";
}
}
1;
|
|
|
# infobot :: Kevin Lenzo (c) 1997
sub normquery {
my ($in) = @_;
$in = " $in ";
# where blah is -> where is blah
$in =~ s/ (where|what|who)\s+(\S+)\s+(is|are) / $1 $3 $2 /i;
# where blah is -> where is blah
$in =~ s/ (where|what|who)\s+(.*)\s+(is|are) / $1 $3 $2 /i;
$in =~ s/^\s*(.*?)\s*/$1/;
$in =~ s/be tellin\'?g?/tell/i;
$in =~ s/ \'?bout/ about/i;
$in =~ s/,? any(hoo?w?|ways?)/ /ig;
$in =~ s/,?\s*(pretty )*please\??\s*$/\?/i;
# what country is ...
if ($in =~
s/wh(at|ich)\s+(add?res?s|country|place|net (suffix|domain))/wh$1 /ig) {
if ((length($in) == 2) && ($in !~ /^\./)) {
$in = '.'.$in;
}
$in .= '?';
}
# profanity filters. just delete it
$in =~ s/th(e|at|is) (((m(o|u)th(a|er) ?)?fuck(in\'?g?)?|hell|heck|(god-?)?damn?(ed)?) ?)+//ig;
$in =~ s/wtf/where/gi;
$in =~ s/this (.*) thingy?/ $1/gi;
$in =~ s/this thingy? (called )?//gi;
$in =~ s/ha(s|ve) (an?y?|some|ne) (idea|clue|guess|seen) /know /ig;
$in =~ s/does (any|ne|some) ?(1|one|body) know //ig;
$in =~ s/do you know //ig;
$in =~ s/can (you|u|((any|ne|some) ?(1|one|body)))( please)? tell (me|us|him|her)//ig;
$in =~ s/where (\S+) can \S+ (a|an|the)?//ig;
$in =~ s/(can|do) (i|you|one|we|he|she) (find|get)( this)?/is/i; # where can i find
$in =~ s/(i|one|we|he|she) can (find|get)/is/gi; # where i can find
$in =~ s/(the )?(address|url) (for|to) //i; # this should be more specific
$in =~ s/(where is )+/where is /ig;
$in =~ s/\s+/ /g;
$in =~ s/^\s+//;
if ($in =~ s/\s*[\/?!]*\?+\s*$//) {
$finalQMark = 1;
}
# $in =~ s/\b(the|an?)\s+/ /i; # handle first article in query
$in =~ s/\s+/ /g;
$in =~ s/^\s*(.*?)\s*$/$1/;
$in;
}
# for be-verbs
sub switchPerson {
my($in) = @_;
my $safeWho = &purifyNick($who);
# $safeWho will cause trouble in nicks with deleted \W's
$in =~ s/(^|\W)${safeWho}s\s+/$1${who}\'s /ig; # fix genitives
$in =~ s/(^|\W)${safeWho}s$/$1${who}\'s/ig; # fix genitives
$in =~ s/(^|\W)${safeWho}\'(\s|$)/$1${who}\'s$2/ig; # fix genitives
$in =~ s/(^|\s)i\'m(\W|$)/$1$who is$2/ig;
$in =~ s/(^|\s)i\'ve(\W|$)/$1$who has$2/ig;
$in =~ s/(^|\s)i have(\W|$)/$1$who has$2/ig;
$in =~ s/(^|\s)i haven\'?t(\W|$)/$1$who has not$2/ig;
$in =~ s/(^|\s)i(\W|$)/$1$who$2/ig;
$in =~ s/ am\b/ is/i;
$in =~ s/\bam /is/i;
$in =~ s/yourself/$param{'ident'}/i if ($addressed);
$in =~ s/(^|\s)(me|myself)(\W|$)/$1$who$3/ig;
$in =~ s/(^|\s)my(\W|$)/$1${who}\'s$2/ig; # turn 'my' into name's
$in =~ s/(^|\W)you\'?re(\W|$)/$1you are$2/ig;
if ($addressed > 0) {
$in =~ s/(^|\W)are you(\W|$)/$1is $param{'nick'}$2/ig;
$in =~ s/(^|\W)you are(\W|$)/$1$param{'nick'} is$2/ig;
$in =~ s/(^|\W)you(\W|$)/$1$param{'nick'}$2/ig;
$in =~ s/(^|\W)your(\W|$)/$1$param{'nick'}\'s$2/ig;
}
$in;
}
# ---
1;
|
|
|
# infobot :: Kevin Lenzo (c) 1997
if (!$filesep) {
$filesep = '/';
};
sub loadParamFiles {
my (@files) = @_;
my @result;
my $p;
if (!@files) {
# &status("no param files to load");
return '';
}
foreach $p (@files) {
if ($p !~ /\S/) {
&status("warning: param file name is null");
return '';
}
if (open(PARAM, $p)) {
my $count;
while (<PARAM>) {
chomp;
next if /^\s*\#/;
next unless /\S/;
my ($key, $val) = split(/\s+/, $_, 2);
# perform variable interpolation
$val =~ s/(\$(\w+))/$param{$2}/g;
&status("setting $key => $val")
if (exists $param{VERBOSITY} and $param{VERBOSITY} > 2);
$param{$key} = $val;
++$count;
}
&status("loaded param file $p ($count items)");
close(PARAM);
} else {
&status("failed to load param file $p");
}
}
}
sub writeParamFile {
my ($filename) = $_[0];
# write the current parameter set to $filename.
# returns 1 if successful
if (open POUT, ">$filename") {
foreach (sort keys %param) {
print POUT "$_ $param{$_}\n";
}
close POUT;
return 1;
} else {
# couldn't write the file
return 0;
}
}
1;
|
|
|
# infobot :: Kevin Lenzo 1997-1999
# process the incoming message
$SIG{'ALRM'} = 'TimerAlarm';
my $blocked;
#----------------------------------------------------------
sub sayIt
{
my ($msgType, $who, $msg) = @_;
if ($msgType =~ /private/ and $who ne '')
{
&msg($who, $msg);
}
else
{
if ($who eq '')
{
&say($msg . "$who");
}
else
{
&say($msg . ", $who");
}
}
}
#------------------------------------------------------------------------
sub CheckEmptyMessages
{
my ($message) = @_;
return 'NOREPLY' if $message =~ /^...but/;
return 'NOREPLY' if $message =~ /^.* already had it that way/;
return 'NOREPLY' if $message =~ /^told /; # reply from friendly infobot
return 'NOREPLY' if $message =~ /^[!\*]/;
return 'NOREPLY' if $message =~ /^gotcha/i;
return 0;
}
#------------------------------------------------------------------------
sub CheckMyRoutines
{
my $mr = &myRoutines();
return 0 unless $mr =~ /\S+/;
&status("myRoutines: $mr");
return $mr;
}
#------------------------------------------------------------------------
sub CheckIgnoreList
{
my ($uh, $who, $message) = @_;
# this assumes that the ignore list will be fairly small, as we
# loop through each key rather than doing a straight lookup
if ($ignoreList{$uh} or $ignoreList{$who})
{
&status("IGNORE <$who> $message");
return 'NOREPLY';
}
foreach (keys %ignoreList)
{
my $ignoreRE = $_;
my @parts = split /\*/, "a${ignoreRE}a";
my $recast = join '\S*', map quotemeta($_), @parts;
$recast =~ s/^a(.*)a$/$1/;
if ($nuh =~ /^$recast$/)
{
&status("IGNORE <$who> $message");
return 'NOREPLY';
}
}
return 0;
}
#------------------------------------------------------------------------
sub CheckInfobotMessage
{
my ($msgType, $nuh, $who, $message) = @_;
if ($msgType =~ /private/ and $message =~ s/^:INFOBOT://)
{
&status("infobot <$nuh> identified") unless $infobots{$nuh};
$infobots{$nuh} = $who;
}
return 0 unless $infobots{$nuh};
return 'NOREPLY' unless $msgType =~ /private/;
if ($message =~ /^QUERY (<.*?>) (.*)/)
{
my $r;
my $target = $1;
my $item = $2;
$item =~ s/[.\?]$//;
&status(":INFOBOT:QUERY $who: $message");
if ($r = &get("is", $item))
{
&msg($who, ":INFOBOT:REPLY $target $item =is=> $r");
}
if ($r = &get("are", $item))
{
&msg($who, ":INFOBOT:REPLY $target $item =are=> $r");
}
return 'NOREPLY';
}
elsif ($message =~ /^REPLY <(.*?)> (.*)/)
{
my $r;
my $target = $1;
my $item = $2;
&status(":INFOBOT:REPLY $who: $message");
my ($X, $V, $Y) = $item =~ /^(.*?) =(.*?)=> (.*)/;
if (($param{'acceptUrl'} !~ /REQUIRE/) or ($Y =~ /(http|ftp|mailto|telnet|file):/))
{
&set($V, $X, $Y);
&msg($target, "$who knew: $X $V $Y");
}
return 'NOREPLY';
}
return 0;
}
#------------------------------------------------------------------------
sub CheckVerification
{
my ($msgType, $nuh, $who, $message) = @_;
my $VerifWho = &verifyUser($nuh);
return 0 unless ($VerifWho);
if (IsFlag("i") eq "i")
{
&status("Ignoring $who: $VerifWho");
return 'NOREPLY';
}
return 0 unless ($msgType =~ /private/);
# it's a private message
my ($potentialPass) = $message =~ /^\s*(\S+)/;
if (exists($verified{$VerifWho}))
{
# aging. you need to keep talking to it re-verify
if (time() - $verified{$VerifWho} < 60*60)
{
# 1 hour decay
$verified{$VerifWho} = $now;
}
else
{
&status("verification for $VerifWho expired");
delete $verified{$VerifWho};
}
}
if ($uPasswd eq "NONE_NEEDED")
{
&status("no password needed for $VerifWho");
$verified{$verifWho} = $now;
}
if (&ckpasswd($potentialPass, $uPasswd))
{
$message =~ s/^\s*\S+\s*//;
$origMessage =~ s/^\s*\S+\s*/<PASSWORD> /;
&status("password verified for $VerifWho");
$verified{$VerifWho} = $now;
if ($message =~ /^\s*$/)
{
&msg($who, "i recognize you there");
return 'NOREPLY';
}
}
return 0;
}
#----------------------------------------------------------
sub CheckFeedbackAddressing
{
my ($msgType, $who, $message) = @_;
return 0 unless ($message =~ /^\s*$param{'nick'}\s*\?*$/i);
&status("feedback addressing from $who");
#$addressed = 1;
#$blocked = 0;
if ($msgType =~ /public/)
{
if (rand() > 0.5)
{
&performSay("yes, $who?");
}
else
{
&performSay("$who?");
}
}
else
{
#private
&msg($who, "yes?");
}
$lastaddressedby = $who;
$lastaddressedtime = time();
return '';
}
#----------------------------------------------------------
sub AmIBeingAddressed
{
my ($addressed, $blocked, $message) = @_;
if (($message =~ /^\s*$param{'nick'}\s*([\,\:\> ]+) */i)
or ($message =~ /^\s*$param{'nick'}\s*-+ *\??/i))
{
# i have been addressed!
my($it) = $&;
if ($' !~ /^\s*is/i)
{
$message = $';
$addressed = 1;
$blocked = 0;
}
}
if ($message =~ /, ?$param{nick}(\W+)?$/i)
{
# i have been addressed!
my($it) = $&;
if ($` !~ /^\s*i?s\s*$/i)
{
my $xxx = quotemeta($it);
$message =~ s/$xxx//;
$addressed = 1;
$blocked = 0;
}
}
if ($addressed)
{
&status("$who is addressing me");
$lastaddressedby = $who;
$lastaddressedtime = time();
}
else
{
my ($now, $diff);
$now = time();
$diff = $now - $lastaddressedtime;
if ($who eq $lastaddressedby and $diff < 10)
{
# assume we're talking to the same person even if we're
# not addressed, if we've been addressed in 10 seconds
$addressed = 1;
&status("assuming continuity of address by $who ($diff seconds elapsed)");
}
}
return ($addressed, $blocked, $message);
}
#----------------------------------------------------------
sub CheckShowModeRequest
{
my ($addressed, $msgType, $who, $message) = @_;
return 0 unless ($addressed and $message =~ /^showmode/i );
if ($msgType =~ /public/)
{
if (($param{'addressing'} eq 'REQUIRE') && !$addressed)
{
return "NOREPLY";
}
else
{
&performSay ($who.", addressing me is currently in $param{addressing} mode.");
return "NOREPLY";
}
}
else
{
&msg($who, "addressing me is currently in $param{addressing} mode");
return "NOREPLY";
}
return 0;
}
#----------------------------------------------------------
sub CheckSubstitutionRequest
{
my ($addressed, $msgType, $who, $message) = @_;
return 0 unless ($addressed and $message =~ m|^\s*(.*?)\s+=~\s*s\/(.+?)\/(.*?)\/([a-z]*);?\s*$|);
# substitution: X =~ s/A/B/
my ($X, $oldpiece, $newpiece, $flags) = ($1, $2, $3, $4);
my $matched = 0;
my $subst = 0;
my $op = quotemeta($oldpiece);
my $np = $newpiece;
$X = lc($X);
foreach $d ("is","are")
{
if ($r = get($d, $X))
{
my $old = $r;
$matched++;
if ($r =~ s/$op/$np/i)
{
if (length($r) > $param{maxDataSize})
{
sayIt($msgType, $who, "That's too long");
return 'NOREPLY';
}
set($d, $X, $r);
&status("update: '$X =$d=> $r'; was '$old'");
$subst++;
}
}
}
if ($matched)
{
if ($subst)
{
sayIt($msgType, $who, "OK");
}
else
{
sayIt($msgType, $who, "That doesn't contain '$oldpiece'");
}
}
else
{
sayIt($msgType, $who, "I didn't have anything matching '$X'");
}
return 'NOREPLY';
}
#----------------------------------------------------------
sub CheckSayRequest
{
my ($addressed, $msgType, $who, $message) = @_;
return 0 unless ($addressed and IsFlag("S"));
if ($message =~ s/^\s*say\s+(\S+)\s+(.*)//)
{
&msg($1, $2);
&msg($who, "ok.");
return 'NOREPLY';
}
return 0;
}
#----------------------------------------------------------
sub CheckForgetRequest
{
my ($addressed, $msgType, $who, $message) = @_;
return 0 unless ($addressed and $message =~ s/^forget\s+((a|an|the)\s+)?//i);
# cut off final punctuation
$message =~ s/[.!?]+$//;
#return 'no authorization to lobotomize';
#}
$k = &normquery($message);
$k = lc($k);
$found = 0;
foreach $d ("is", "are")
{
if ($r = get($d, $k))
{
if (IsFlag("r") ne "r")
{
performReply("you have no access to remove factoids");
return '';
}
$found = 1 ;
&status("forget: <$who> $k =$d=> $r");
clear($d, $k);
$factoidCount--;
}
}
if ($found == 1)
{
sayIt($msgType, $who, "I forgot $k");
$l = $who; $l =~ s/^=//;
$updateCount++;
}
else
{
sayIt($msgType, $who, "I didn't have anything matching $k");
}
return 'NOREPLY';
}
#----------------------------------------------------------
sub CheckWakeupRequest
{
my ($addressed, $msgType, $who, $message) = @_;
# Aldebaran++ !
return 0 unless ($addressed and $param{"shutup"} and $message =~ /^\s*wake\s*up\s*$/i );
if ($msgType =~ /public/)
{
if ($addressed)
{
if (rand() > 0.5)
{
&performSay("Ok, ".$who.", I'll start talking.");
&status("Changing to Optional mode");
$param{'addressing'} = 'OPTIONAL';
return "NOREPLY";
}
else
{
&performSay(":O");
return "NOREPLY";
}
}
}
else
{
&msg($who, "OK, I'll start talking.");
$param{'addressing'} = 'OPTIONAL';
&status("Changing to Optional mode");
return "NOREPLY";
}
return 0;
}
#----------------------------------------------------------
sub CheckShutupRequest
{
my ($addressed, $msgType, $who, $message) = @_;
return 0 unless ($addressed and $param{"shutup"} and $message =~ /^\s*shut\s*up\s*$/i );
if ($msgType =~ /public/)
{
if ($addressed)
{
if (rand() > 0.5)
{
&performSay("Sorry, ".$who.", I'll keep my mouth shut. ");
$param{'addressing'} = 'REQUIRE';
&status("Changing to Require mode");
return "NOREPLY";
}
else
{
&performSay(":X");
return "NOREPLY";
}
}
}
else
{
&msg($who, "Sorry, I'll try to be quiet.");
$param{'addressing'} = 'REQUIRE';
&status("Changing to Require mode");
return "NOREPLY";
}
return 0;
}
#----------------------------------------------------------
sub CheckSeenDB
{
my ($addressed, $msgType, $who, $message) = @_;
return 0 unless ($message =~ /^seen (\S+)/);
my $person = $1;
$person =~ s/\?*\s*$//;
if ($seen{lc $person})
{
my ($when,$what) = split /$;/, $seen{lc $person};
my $howlong = time() - $when;
$when = localtime $when;
my $tstring = ($howlong % 60). " seconds ago";
$howlong = int($howlong / 60);
if ($howlong % 60)
{
$tstring = ($howlong % 60). " minutes and $tstring";
}
$howlong = int($howlong / 60);
if ($howlong % 24)
{
$tstring = ($howlong % 24). " hours, $tstring";
}
$howlong = int($howlong / 24);
if ($howlong % 365)
{
$tstring = ($howlong % 365). " days, $tstring";
}
$howlong = int($howlong / 365);
if ($howlong > 0)
{
$tstring = "$howlong years, $tstring";
}
sayIt($msgType, $who, "$person was last seen $tstring, saying: '$what' [$when]");
return 'NOREPLY';
}
if ($msgType =~ /public/)
{
&performSay("I haven't seen '$person', $who");
}
else
{
&msg($who,"I haven't seen '$person', $who");
}
return 'NOREPLY';
}
#----------------------------------------------------------
sub CheckGreetings
{
my ($addressed, $msgType, $who, $message) = @_;
#return 'NOREPLY' unless ($addressed and $message =~ /^\s*heya?,? /);
# Gotta be gender-neutral here... we're sensitive to purl's needs. :-)
return 0 unless ($message =~ /^\s*(hey)?(good( fuckin['g]?)? (bo(t|y)|g([ui]|r+)rl))|(bot( |\-)?snack)/i);
&status("random praise");
if ($msgType =~ /public/)
{
if ((time() - $prevTime <= 15) || ($addressed))
{
if (rand() < .5)
{
&performSay("thanks $who :)");
}
else
{
&performSay(":)");
}
}
}
else
{
&msg($who, ":)");
}
return 'NOREPLY';
}
#----------------------------------------------------------
sub CheckHello
{
my ($addressed, $msgType, $who, $message) = @_;
return 0 unless ($message =~ /^\s*(h(ello|i( there)?|owdy|ey|ola)|salut|bonjour|niihau|que\s*tal)( $param{nick})?\s*$/i);
# 65% chance of replying to a random greeting when not addressed
return 0 if (!$addressed and rand() > 0.35);
my($r) = $hello[int(rand(@hello))];
sayIt($msgType, $who, $r);
return 'NOREPLY';
}
#----------------------------------------------------------
sub CheckPraise
{
my ($addressed, $msgType, $who, $message) = @_;
return 0 unless ($addressed and $message =~ /you (rock|rocks|rewl|rule|are so+ co+l)/);
if (rand() < .5)
{
&performSay("thanks $who :)");
}
else
{
&performSay(":)");
}
return 'NOREPLY';
}
#----------------------------------------------------------
sub CheckThanks
{
my ($addressed, $msgType, $who, $message) = @_;
return 0 unless ($addressed and $message =~ /thank(s| you)/i);
my $msg;
if (rand() < .5)
{
$msg = $welcomes[int(rand(@welcomes))];
}
else
{
$msg = ": ".$welcomes[int(rand(@welcomes))];
}
sayIt($msgType, $who, $msg);
return 'NOREPLY';
}
#----------------------------------------------------------
sub CheckNslookupRequest
{
my ($addressed, $msgType, $who, $message) = @_;
return 0 unless (($message =~ /^nslookup (\S+)$/i) and $param{allowDNS});
&status("DNS Lookup: $1");
&DNS($1);
return 'NOREPLY';
}
#----------------------------------------------------------
sub CheckSpellRequest
{
my ($addressed, $msgType, $who, $message) = @_;
return 0 unless ($param{ispell} and ($message =~ s/^spell(ing)? (?:of|for )?//));
&ispell($message);
return 'NOREPLY';
}
#----------------------------------------------------------
sub CheckTraceRouteRequest
{
my ($addressed, $msgType, $who, $message) = @_;
return 0 unless (($message =~ /^traceroute (\S+)$/i) and $param{allowTraceroute});
&status("traceroute to $1");
&troute($1);
return 'NOREPLY';
}
#----------------------------------------------------------
sub CheckEncryptRequest
{
my ($addressed, $msgType, $who, $message) = @_;
return 0 unless ($message =~ /^crypt\s*\(\s*(\S+)\s*(?:,| )\s*(\S+)/);
my $cr = crypt($1, $2);
sayIt($msgType, $who, $cr);
return 'NOREPLY';
}
#----------------------------------------------------------
sub CheckInternicRequest
{
my ($addressed, $msgType, $who, $message) = @_;
return 0 unless (($message =~ /^internic (\S+)$/i) and $param{allowInternic});
&status("internic whois query: $1");
&domain_summary($1);
return 'NOREPLY';
}
#----------------------------------------------------------
sub CheckShowDBRequest
{
my ($addressed, $msgType, $who, $message) = @_;
return 0 unless ($message =~ /^showdb (\S+) ?(\S+)?$/i);
&status("showdb query: $1 $2");
my @res = &showdb($1, $2);
if ($2 eq '')
{
sayIt($msgType, $who, "here's everything I know from the '$1' db");
}
else
{
sayIt($msgType, $who, "here's everything I know about '$2' in the '$1' db");
}
my $fact;
foreach $fact (@res)
{
sayIt($msgType, '', ' ' .$fact);
}
sayIt($msgType, $who, "that's it");
return 'NOREPLY';
}
#----------------------------------------------------------
sub CheckLeaveRequest
{
my ($addressed, $msgType, $who, $message) = @_;
return 0 unless ($param{'allowLeave'} =~ /$msgType/);
return 0 unless ($message =~ /(leave|part) ((\#|\&)\S+)/i);
return 0 unless (IsFlag("o") or $addressed);
if (IsFlag("c") ne "c")
{
&performReply("you don't have the channel flag");
return 'NOREPLY';
}
&channel($2);
&performSay("goodbye, $who.");
&status("PART $2 <$who>");
&part($2);
return 'NOREPLY';
}
#----------------------------------------------------------
sub CheckJoinRequest
{
my ($addressed, $msgType, $who, $message, $channel) = @_;
return 0 unless ($msgType !~ /public/);
# accept only msgs leaves/joins
my($ok_to_join);
return 0 unless ($message =~ /join ([&#]\S+)(?:\s+(\S+))?/i );
# Thanks to Eden Li (tile) for the channel key patch
my($which, $key) = ($1, $2);
$key = defined ($key) ? " $key" : "";
foreach $chan (split(/\s+/, $param{'allowed_channels'}))
{
if (lc($which) eq lc($chan))
{
$ok_to_join = $which . $key;
last;
}
}
if (IsFlag("o"))
{
$ok_to_join = $which.$key;
}
if (! $ok_to_join)
{
&msg($who, "I am not allowed to join that channel.");
}
else
{
if (IsFlag("c") ne "c")
{
&msg($who, "You don't have the channel flag");
return 'NOREPLY';
}
joinChan($ok_to_join);
&status("JOIN $ok_to_join <$who>");
&msg($who, "joining $ok_to_join")
unless ($channel eq &channel());
sleep(1);
# my $temp = &channel();
# &performSay("hello, $who.");
# &channel($temp);
}
return 'NOREPLY';
}
#----------------------------------------------------------
sub CheckStatement
{
my ($addressed, $msgType, $who, $message, $holdMessage) = @_;
return "No authorization to teach" unless (IsFlag("t") eq "t");
return 'NOREPLY' unless ($param{'allowUpdate'});
my $result = &doStatement($msgType, $holdMessage);
# print "x='$result' msg='$message' hm='$holdMessage'\n";
return 'NOREPLY' if ($who eq 'NOREPLY' || $result eq 'NOREPLY');
return 'NOREPLY' if grep $_ eq $who, split /\s+/, $param{friendlyBots};
if ($result !~ /^\s*$/)
{
&msg($who, "gotcha.") if ($msgType !~ /public/);
}
else
{
if ($msgType !~ /public/ || $addressed)
{
&msg($who, $confused[int(rand(@confused))]);
}
if ($msgType =~ /public/)
{
&status("unparseable: $message");
}
}
return 'NOREPLY';
}
#----------------------------------------------------------
sub CheckQuestion
{
my ($addressed, $msgType, $who, $message) = @_;
my($result) = "";
$result = &doQuestion($msgType, $message) unless ($who eq 'NOREPLY');
return 'NOREPLY' if ($result eq 'NOREPLY' or $who eq 'NOREPLY');
return 0 unless ($result);
return 'NOREPLY' if (($param{'addressing'} eq "REQUIRE") and !$addressed);
return 'NOREPLY' if (!$finalQMark and !$addressed and ($input_message_length < $param{'minVolunteerLength'}));
return 'NOREPLY' if ($result =~ /^\s*$/);
&status("question: <$who> $message");
$questionCount++;
if ($msgType =~ /public/)
{
if (!$target or !$answer or ($who eq $target))
{
if ($result)
{
&performSay($result) unless $blocked;
}
else
{
&performSay("i didn't have anything matching $tell_obj, $who");
}
return 'NOREPLY';
}
my $r = "$who wants you to know: $result";
&msg($target, $r);
if ($who ne $target)
{
&msg($who, "told $target about $tell_obj ($r)");
}
return 'NOREPLY';
}
# not public
if ($answer eq "" or $who eq $target)
{
&msg($who, $result);
return 'NOREPLY';
}
# to someone else
my $r = "$who wants you to know: $result";
&msg($target, $r);
&msg($who, "told $target about $tell_obj ($r)");
return 'NOREPLY';
}
#----------------------------------------------------------
sub process
{
($who, $msgType, $message) = @_;
$origMessage = $message;
$message =~ s/[\cA-\c_]//ig; # strip control characters
$addressed = 0;
my $rc;
return if $instance =~ /antihelp/;
my ($n, $uh) = ($nuh =~ /^([^!]+)!(.*)/);
if ($param{'VERBOSITY'} > 3)
{
# murrayb++
&status("Splitting incoming address into $n and $uh");
}
if ($msgType =~ /private/ and $message =~ /^hey, what is/)
{
$infobots{$nuh} = $who;
&msg($who, "inter-infobot communication now requires version 0.43 or higher.");
return 'NOREPLY';
}
$rc = CheckEmptyMessages($message);
return $rc if $rc;
$rc = CheckIgnoreList($uh, $who, $message);
return $rc if $rc;
return 'NOREPLY' if (lc($who) eq lc($param{'nick'}));
$rc = CheckInfobotMessage($msgType, $nuh, $who, $message);
return $rc if $rc;
$rc = CheckVerification($msgType, $nuh, $who, $message);
return $rc if $rc;
# see User.pl for the "special" user commands
return 'NOREPLY' if &userProcessing() eq 'NOREPLY';
$addressed = 1 if ($msgType !~ /public/);
$rc = CheckFeedbackAddressing($msgType, $who, $message);
return $rc if $rc eq '';
($addressed, $blocked, $message) = AmIBeingAddressed($addressed, $blocked, $message);
if ($addressed)
{
my $channel = &channel();
}
$rc = CheckShowModeRequest($addressed, $msgType, $who, $message);
return $rc if $rc;
$rc = CheckSubstitutionRequest($addressed, $msgType, $who, $message);
return $rc if $rc;
$rc = CheckSayRequest($addressed, $msgType, $who, $message);
return $rc if $rc;
$rc = CheckForgetRequest($addressed, $msgType, $who, $message);
return $rc if $rc;
$rc = CheckWakeupRequest($addressed, $msgType, $who, $message);
return $rc if $rc;
$rc = CheckShutupRequest($addressed, $msgType, $who, $message);
return $rc if $rc;
$target = $who;
$skipReply = 0;
$message_input_length = length($message);
foreach $x (@confused)
{
$y = quotemeta($x);
return "" if $message =~ /^\s*$y\s*/;
}
return if ($who eq $param{'nick'});
$message =~ s/^\s+//; # strip any dodgey spaces off
if (($message =~ s/^\S+\s*:\s+//) or ($message =~ s/^\S+\s+--+\s+//))
{
# stripped the addressee ("^Pudge: it's there")
$reallyTalkingTo = $1;
}
else
{
$reallyTalkingTo = '';
if ($addressed)
{
$reallyTalkingTo = $param{'nick'};
}
}
# here's where the external routines get called.
# if they return anything but null, that's the "answer".
$rc = CheckMyRoutines();
return $rc if $rc;
# might want to take this out.
$rc = CheckSeenDB($addressed, $msgType, $who, $message);
return $rc if $rc;
$rc = CheckGreetings($addressed, $msgType, $who, $message);
return $rc if $rc;
$rc = CheckPraise($addressed, $msgType, $who, $message);
return $rc if $rc;
$rc = CheckThanks($addressed, $msgType, $who, $message);
return $rc if $rc;
$rc = CheckHello($addressed, $msgType, $who, $message);
return $rc if $rc;
$rc = CheckNslookupRequest($addressed, $msgType, $who, $message);
return $rc if $rc;
$rc = CheckSpellRequest($addressed, $msgType, $who, $message);
return $rc if $rc;
$rc = CheckTraceRouteRequest($addressed, $msgType, $who, $message);
return $rc if $rc;
$rc = CheckEncryptRequest($addressed, $msgType, $who, $message);
return $rc if $rc;
$rc = CheckInternicRequest($addressed, $msgType, $who, $message);
return $rc if $rc;
$rc = CheckShowDBRequest($addressed, $msgType, $who, $message);
return $rc if $rc;
$message =~ s/^\s*hey,?\s+where/where/i;
$message =~ s/whois/who is/ig;
$message =~ s/where can i find/where is/i;
$message =~ s/how about/where is/i;
$message =~ s/^(gee|boy|golly|gosh),? //i;
$message =~ s/^(well|and|but|or|yes),? //i;
$message =~ s/^(does )?(any|ne)(1|one|body) know //i;
$message =~ s/ da / the /ig;
$message =~ s/^heya?,?( folks)?,*\.* *//i; # clear initial filled pauses & stuff
$message =~ s/^[uh]+m*[,\.]* +//i;
$message =~ s/^o+[hk]+(a+y+)?,*\.* +//i;
$message =~ s/^g(eez|osh|olly)+,*\.* +(.+)/$2/i;
$message =~ s/^w(ow|hee|o+ho+)+,*\.* +(.+)/$2/i;
$message =~ s/^still,* +//i;
$message =~ s/^well,* +//i;
$message =~ s/^\s*(stupid )?q(uestion)?:\s+//i;
# may not want to cut off all: all i know is ...
# but for now seem mostly content-free
$rc = CheckLeaveRequest($addressed, $msgType, $who, $message);
return $rc if $rc;
$rc = CheckJoinRequest($addressed, $msgType, $who, $message, $channel);
return $rc if $rc;
if (($message =~ s/^(no,?\s+$param{'nick'},?\s*)//i) or
($addressed and $message =~ s/^(no,?\s+)//i))
{
# clear initial negative
# an initial negative may signify a correction
$correction_plausible = 1;
&status("correction is plausible, initial negative and nick deleted ($1)") if ($param{VERBOSITY} > 2);
}
else
{
$correction_plausible = 0;
}
my $holdMessage = $message;
$rc = CheckQuestion($addressed, $msgType, $who, $message);
return $rc if $rc;
# no reply from doQ
$rc = CheckStatement($addressed, $msgType, $who, $message, $holdMessage);
return $rc if $rc;
}
1;
|
|
|
# infobot :: Kevin Lenzo (c) 1997
##
## doQuestion --
##
## decide if $in is a query, and if so, return its value.
## otherwise return null.
##
sub doQuestion
{
local ($msgType, $in) = @_;
chomp $in;
$finalQMark = $in =~ s/\?+\s*$//;
$questionWord = ""; # this is shared for a reason
$input_message_length = length($in);
my($locWho) = $who;
local ($lhs, $res, $num);
$locWho =~ tr/A-Z/a-z/;
$locWho =~ s/^=//;
my ($origIn) = $in;
$finalQMark += $in =~ s/\?\s*$//;
# dangerous; common preambles should be stripped before here
if ($in !~ /^forget /i and $in !~ /^no, /)
{
$result = &getReply($msgType, $in);
if ($result)
{
&status("match: $in => $result");
return $result;
}
}
else
{
return 'NOREPLY' if $infobots{$nuh};
}
if (($addressed) && ($in =~ /^\s*help\b/i))
{
$in =~ s/^\s*help\s*//i;
$in =~ s/\W+$//;
&help($in);
return 'NOREPLY';
}
if (IsFlag("s") eq "s")
{
if ($in =~ /^\s*(scan|search)\s*for\s+/i)
{
&search($`);
return 'NOREPLY';
}
}
if ($param{'allowConv'})
{
if ($in =~ /^\s*(asci*|chr) (\d+)\s*$/)
{
$num = $2;
if ($num < 32)
{
$num += 64;
$res = "^".chr($num);
}
else
{
$res = chr($2);
}
if ($num == 0)
{
$res = "NULL"; } ;
return "ascii ".$2." is \'".$res."\'";
}
if ($in =~ /^\s*ord (.)\s*$/)
{
$res = $1;
if (ord($res) < 32)
{
$res = chr(ord($res) + 64);
if ($res eq chr(64))
{
$res = 'NULL';
}
else
{
$res = '^'.$res;
}
}
return "\'$res\' is ascii ".ord($1);
}
}
if ($param{'plusplus'})
{
my $in2 = $in;
if ($in2 =~ s/^(karma|score)\s+(for\s+)?//)
{
$in2 = lc($in2);
$in2 =~ s/\s+/ /g;
if ($in2 eq "me")
{
$in2 = lc($who);
}
if (defined($plusplus{$in2}) and $plusplus{$in2})
{
return "$in2 has karma of $plusplus{$in2}";
}
else
{
return "$in2 has neutral karma";
}
}
}
if (($addressed) && ($in =~ /^statu?s/))
{
$upString = &timeToString(time()-$startTime);
$eTime = &get("is", "the qEpochDate");
return "Since $setup_time, there have been $updateCount modifications and $questionCount questions. I have been awake for $upString this session, and currently reference $factoidCount factoids. Addressing is in ".lc($param{addressing})." mode.";
# Since ".$is{"the qEpochDate"}." there have been about ".$is{"the qCount"}." questions total.";
}
# the thing to tell someone about ($tell_obj)
$tell_obj = "";
# who to tell
$target = $who;
# i'm telling!
if ($param{'allowTelling'})
{
# this one catches most of them
if ($in =~ /^tell\s+(\S+)\s+about\s+(.*)/i)
{
$target = $1;
$tell_obj = $2;
if ($target =~ /^us$/i)
{
# tell us
$target = "";
}
elsif ($tell_obj =~ /^(me|myself)$/i)
{
$tell_obj = $who;
}
$in = $tell_obj;
}
elsif ($in =~ /tell\s+(\S+)\s+where\s+(\S+)\s+can\s+(\S+)\s+(.*)/i)
{
# i'm sure this could all be nicely collapsed
$target = $1;
$tell_obj = $4;
if ($target =~ /^us$/i)
{
$target = "";
}
$in = $tell_obj;
}
elsif ($in =~ /tell\s+(\S+)\s+(what|where)\s+(.*?)\s+(is|are)[.?!]*$/i)
{
$target = $1;
$qWord = $2;
$tell_obj = $3;
$verb = $4;
if ($target =~ /^us$/i)
{
$target = "";
}
$in = "$qWord $verb $tell_obj";
}
if (($target =~/^\s*[\&\#]/) or ($target =~ /\,/))
{
$target = "";
$tell_obj = "";
return "No, ".$who.", i won\'t";
}
if ($target eq $param{'nick'})
{
$target = "";
return "Isn\'t that a bit silly, ".$who."?";
}
$tell_obj =~ s/[\.\?!]+$//;
}
# convert to canonical reference form
$in = &normquery($in);
$in = &switchPerson($in);
# where is x at?
$in =~ s/\s+at\s*(\?*)$/$1/;
$in = " $in ";
my $qregex = join '|', @qWord;
# what's whats => what is; who'?s => who is, etc
$in =~ s/ ($qregex)\'?s / $1 is /i;
if ($in =~ s/\s+($qregex)\s+//i)
{
# check for question word
$questionWord = lc($1);
}
$in =~ s/^\s+//;
$in =~ s/\s+$//;
if (($questionWord eq "") && ($finalQMark > 0) && ($addressed > 0))
{
$questionWord = "where";
}
# $lhs (left hand side) becomes the result of the query
# about $in (otherwise knowable as $rhs, the right hand side)
$lhs = &getReply($msgType, $in);
$answer = $lhs;
return 'NOREPLY' if ($answer eq 'NOREPLY');
if (($param{'addressing'} eq 'REQUIRE') && !$addressed)
{
return 'NOREPLY';
}
&math(); # clean up the argument syntax for this later
if ($questionWord ne "" or $finalQMark)
{
# if it has not been explicitly marked as a question
if (($addressed > 0) && ($lhs eq ""))
{
# and we're addressed and so far the result is null
&status("notfound: <$who> $origIn :: $in");
my($reply) = "";
return 'NOREPLY' if $infobots{$nuh};
# generate some random i-don't-know reply.
if (0 and ($x = rand()) > 0.8)
{
$reply = "well ";
}
$reply .= $dunno[int(rand(@dunno))];
if (rand() > 0.5)
{
$reply = $locWho.": ".$reply;
}
else
{
$reply = $reply.", ".$locWho;
}
&askFriendlyBots($in);
# and set the result
$lhs = $reply;
}
}
else
{
# the item was found
if ($lhs ne "")
{
&status("match: $in => $lhs");
}
}
$lhs;
}
sub timeToString
{
my $upTime = $_[0];
$upTime = (time()-$startTime);
my $upDays = int($upTime / (60*60*24));
my $upString = "";
if ($upDays > 0)
{
$upString .= $upDays." day";
$upString .= "s" if ($upDays > 1);
$upString .=", ";
}
$upTime -= $upDays * 60*60*24;
my $upHours = int($upTime / (60*60));
if ($upHours > 0)
{
$upString .= $upHours." hour";
$upString .= "s" if ($upHours > 1);
$upString .=", ";
}
$upTime -= $upHours *60*60;
my $upMinutes = int($upTime / 60);
if ($upMinutes > 0)
{
$upString .= $upMinutes." minute";
$upString .= "s" if ($upMinutes > 1);
$upString .=", ";
}
$upTime -= $upMinutes * 60;
my $upSeconds = $upTime;
$upString .= $upSeconds." second";
$upString .= "s" if ($upSeconds != 1);
$upString;
}
1;
|
|
|
You will need to update your infobot.config
and infobot.users. See the example files.
--
This requires perl 5.
You should be able to start up just by running
infobot. If you are using macperl, you will
(currently) have to make one minor change (because
$^O didn't work for me under os8).
The infobot uses parameter files, typically in the
params directory, to set up with. It treats anything
on the command line as a parameter file and tries to
load it.
If you are using macperl, you will want to set
the value of the macperl parameter to 1 in the
two given param files (in the 'files' dir).
By default, the infobot uses the IRC setup. This
may change. NOTE that the irc version has no output
by default; you'll have to turn up the debug level
to get more.
to start up the infobot, just invoke it from the
command line.
infobot
---
A note on forms: you can prepend the tag <reply>
to values in the db to just get a reply with no
extra info.
e.g.
x => <reply> y
then when you ask 'x?' it will just reply 'y' instead
of something like "i think x is y".
---
* extending the bot by adding your own code
try to keep your changes inside src/myRoutines.pl
so that you can easily just replace this file when
there are new revs. this is called just after some
of the normalization stuff in urlProcess.pl. take
a look at the file for details.
basically, if myRoutines returns non-null, it's
taken to have 'caught' the event. you can just
return '' to let the rest of the processing go at
it.
---
* make_db & dump_db
make_db is a little perl script that will take a
flat ascii file and make an infobot-style db out
of it (currently just a couple of dbm files). You'll
want to make 2, even if theye contain only 1 element
each. it will also simply add (and overwrite entries
in) existing dbs. This is especially nice if
you don't allow updates to the databases through IRC
and just want a collection of permanent factoids.
make_db <inputfile> <dbname>
where <inputfile> is an ascii file like (in the case
of an url-style infobot):
infobot => at http://www.cs.cmu.edu/~lenzo/hocus.html
one key => value per line. In the current setup,
you need an is-database and an are-database, mainly
for legacy reasons about representing plurality and
being able to give the proper form. in the infobot-is.txt
file and infobot-are.txt files you have examples. these
are a fine starting point:
1.1 make_db infobot-is.txt infobot-is
make_db infobot-are.txt infobot-are
2. Now you need to edit infobot to set up your bot.
Don't forget to set the path to perl properly at
the top and make it executable.
3. Then try running infobot. At present, there's a
bunch of VERY BAD code in it, so don't use the -w
switch unless you want to fix a bunch of things and
mail me.
Eventually, kill it and then you'll probably
want to crontab it. included is a sample crontab
and the script that you will need to edit.
dump_db <dbname>
will just make a flat ascii file out of the named db,
e.g.
dump_db infobot-is
good luck, and mail me!
kevin
lenzo@cs.cmu.edu
ps - i am just releasing this _now_ instead of waiting
to fix everything. If you use this and like it,
or even if you don't, please mail me!
---
thanks to:
You, for getting this and using this. Especially if
you mail me and let me put you on the mailing list.
lenzo@cs.cmu.edu
special thanks to:
steve orens (sorens) for being a tour-de-force beta bomber
yo for working with script. this is a big one!
amug and everyone there for hosting the undernet url
#macintosh for dealing with url through his troubled childhood
tris for being an early guinea pig
jadin for pointing out the @verb bug... fixed in 0.17b
chucky burnett for tons of stuff
|
|
|
update_db <filename> <dbname>
adds items in the file <filename> to the db with
the basename <dbname>.
file is of the form provided in ../files/infobot-is.txt
which is to say
<key> => <value>
one per line, and <dbname> is something like infobot-is
if the db doesn't exist, it will be created. if it does
exists, the entries will be added, potentially overwriting
entries that exists with the same key.
NOTE: skips lines that do not contain a => ... you can
add comments this way.
dump_db <dbname>
turns the db into a flat ascii file of the form above.
try e.g.
dump_db infobot-is
run_infobots.pl
you'll need to edit this script to give the right home
directory, but this is for crontabbing the infobot. it
will run it if it's not already running. this is not
highly tested! YMMV.
|
|
|
# infobot :: Kevin Lenzo (c) 1997
sub getReply
{
my($msgType, $message) = @_;
my($theMsg) = "";
my($locMsg) = $message;
# x is y
# x is the lhs (left hand side)
# 'is' is the mhs ("middle hand side".. the "head", or verb)
# y is the Y (right hand side)
my($X, $V, $Y, $result);
my ($theVerb, $orig_Y);
$locMsg =~ tr/A-Z/a-z/;
if ($result = get("is", $locMsg))
{
&status("exact: $message =is=> $result");
$theVerb = "is";
$X = $message;
$V = $theVerb;
$Y = $result;
$orig_Y = $X;
}
elsif ($result = get("are", $locMsg))
{
&status("exact: $message =is=> $result");
$theVerb = "are";
$X = $message;
$V = $theVerb;
$Y = $result;
$orig_Y = $X;
}
else
{
$y_determiner = '';
$verbs = join '|', @verb;
$message = " $message ";
if ($message =~ / ($verbs) /i)
{
$X = $`;
$V = $1;
$Y = $';
$X =~ s/^\s*(.*?)\s*$/$1/;
$Y =~ s/^\s*(.*?)\s*$/$1/;
$orig_Y = $Y;
$Y =~ tr/A-Z/a-z/;
$V =~ s/^\s*(.*?)\s*$/$1/;
if ($Y =~ s/^(an?|the)\s+//)
{
$y_determiner = $1;
}
else
{
$y_determiner = '';
}
if ($questionWord !~ /^\s*$/)
{
if ($V eq "is")
{
$result = &get("is", $Y);
}
else
{
if ($V eq "are")
{
$result = &get("are", $Y);
}
}
}
$theVerb = $V;
}
if ($param{'VERBOSITY'} > 1)
{
my $debugstring = "\tmsgType:\t$msgType\n";
$debugstring .= "\tquestionWord:\t$questionWord\n";
$debugstring .= "\taddressed:\t$addressed\n";
$debugstring .= "\tfinalQMark:\t$finalQMark\n";
$debugstring .= "\tX[$X] verb[$theVerb] det[$y_determiner] Y[$Y]\n";
$debugstring .= "\tresult:\t$result\n";
&status($debugstring);
}
if ($y_determiner)
{
# put the det back on
$Y = "$y_determiner $Y";
}
# search imdb
if ($locMsg =~ s/^\s*(search )?imdb (for )?//)
{
$check = $locMsg;
my $url = $locMsg;
# freeside++ for URL cleanup code
my $date = "";
if ($url =~ s/( \(\d+\))$//)
{
$date = $1; }
$url =~ s/^(The|A|An|Les) (.*)/$2, $1/i;
$url = "http://www.imdb.com/M/title-substring?title=$url$date&type=fuzzy";
$url =~ s/ /+/g;
$V = "-> "; $orig_lhs = $locMsg; $theVerb= "is";
return "$locMsg can be found at $url";
}
if ($locMsg =~ s/^\s*(search )?hyperarchive (for )?//)
{
$locMsg =~ /\w+/;
$check = $locMsg;
my $q = $locMsg;
$q =~ s/\W+//g;
$result = "http://hyperarchive.lcs.mit.edu/cgi-bin/NewSearch?key=$q";
$V = "-> "; $orig_lhs = $locMsg; $theVerb= "is";
return "$locMsg may be sought at $result";
}
# websters
if ($locMsg =~ s/^\s*(search )?websters? (for )?//)
{
$locMsg =~ /\w+/;
$word = $&;
$check = $locMsg;
my $q = $locMsg;
$q =~ s/\W+/+/g;
$result = "http://work.ucsd.edu:5141/cgi-bin/http_webster?$word";
$V = "-> "; $orig_lhs = $locMsg; $theVerb= "is";
return "$locMsg may be sought at $result";
}
# check "is" tables anyway for lhs alone
if (!defined($V))
{
# no explicit head had been found
my $det;
if ($locMsg =~ s/^\s*(an?|the)\s+//)
{
$det = $1;
}
$locMsg =~ s/[.!?]+\s*$//;
my($check) = "";
$check = &get("is", $locMsg);
if ($check ne "")
{
$result = $check;
$orig_Y = $locMsg;
$theVerb = "is";
$V = "is"; # artificially set the head to is
}
else
{
$check = &get("are", $locMsg);
if ($check ne "")
{
$result = $check;
$V = "are"; # artificially set the head to are
$orig_Y = $locMsg;
$theVerb = "are";
}
}
if ($det)
{
$orig_Y = "$det $orig_Y";
}
}
}
if ($V ne "")
{
# if there was a head...
my(@poss) = split("\\|", $result);
$poss[0] =~ s/^\s//;
$poss[$#poss] =~ s/\s$//;
if ((@poss > 1) && ($msgType =~ /public/))
{
$theMsg = $poss[int(rand(@poss))];
$theMsg =~ s/^\s*//;
}
else
{
$theMsg = $result;
}
}
$skipReply = 0;
if ($theMsg ne "")
{
if ($msgType =~ /public/)
{
my $interval = time() - $prevTime;
if ( ($param{'mode'} eq 'IRC' )
&& $param{'repeatIgnoreInterval'}
&& ($theMsg eq $prevMsg)
&& ((time()-$prevTime) < $param{'repeatIgnoreInterval'})) {
&status("repeat ignored ($interval secs < $param{'repeatIgnoreInterval'})");
$skipReply = 1;
$theMsg = "NOREPLY";
$prevTime = time();
}
else
{
$skipReply = 0;
$prevTime = time() unless ($theMsg eq $prevMsg);
$prevMsg = $theMsg;
}
}
# by now $theMsg should contain the result, or null
# this global is nto a great idea
$shortReply = 0;
$noReply = 0;
if (0 and $theMsg =~ s/^\s*<noreply>\s*//i)
{
# specially defined type. No reply. Experimental.
$noReply = 1;
return 'NOREPLY';
}
if (!$msgType)
{
$msgType = 'private';
&status("NO MSG TYPE / set to private\n");
}
if ($msgType !~ /private/ and $theMsg =~ s/^\s*<reply>\s*//i)
{
# specially defined type. only remove '<reply>'
$shortReply = 1;
}
elsif ($msgType !~ /private/ and $theMsg =~ s/^\s*<action>\s*(.*)/\cAACTION $1\cA/i)
{
# specially defined type. only remove '<action>' and make it an action
$shortReply = 1;
}
else
{
# not a short reply
if (!$infobots{$nuh} and $theVerb =~ /is/)
{
my($x) = int(rand(16));
# oh this could be done much better
if ($x <= 5)
{
$theMsg= "$orig_Y is $theMsg";
}
if ($x == 6)
{
$theMsg= "i think $orig_Y is $theMsg";
}
if ($x == 7)
{
$theMsg= "hmmm... $orig_Y is $theMsg";
}
if ($x == 8)
{
$theMsg= "it has been said that $orig_Y is $theMsg";
}
if ($x == 9)
{
$theMsg= "$orig_Y is probably $theMsg";
}
if ($x == 10)
{
$theMsg =~ s/[.!?]+$//;
$theMsg= "rumour has it $orig_Y is $theMsg";
# $theMsg .= " dumbass";
}
if ($x == 11)
{
$theMsg= "i heard $orig_Y was $theMsg";
}
if ($x == 12)
{
$theMsg= "somebody said $orig_Y was $theMsg";
}
if ($x == 13)
{
$theMsg= "i guess $orig_Y is $theMsg";
}
if ($x == 14)
{
$theMsg= "well, $orig_Y is $theMsg";
}
if ($x == 15)
{
$theMsg =~ s/[.!?]+$//;
$theMsg= "$orig_Y is, like, $theMsg";
}
}
else
{
$theMsg = "$orig_Y $theVerb $theMsg" if ($theMsg !~ /^\s*$/);
}
}
}
my $safeWho = &purifyNick($who);
if (!$shortReply)
{
# shouldn't this be in switchPerson?
# this is fixing the person for going back out
# /^onz!lenzo@lenzo.pc.cs.cmu.edu privmsg rurl :*** noctcp: omega42 is/: nested *?+ in regexp at /usr/users/infobot/infobot-current/src/Reply.pl line 266, <FH> chunk 176.
if ($theMsg =~ s/^$safeWho is/you are/i)
{
# fix the person
}
else
{
$theMsg =~ s/^$param{'nick'} is /i am /ig;
$theMsg =~ s/ $param{'nick'} is / i am /ig;
$theMsg =~ s/^$param{'nick'} was /i was /ig;
$theMsg =~ s/ $param{'nick'} was / i was /ig;
if ($addressed)
{
$theMsg =~ s/^you are (\.*)/i am $1/ig;
$theMsg =~ s/ you are (\.*)/ i am $1/ig;
}
else
{
if ($theMsg =~ /^you are / or $theMsg =~ / you are /)
{
$theMsg = 'NOREPLY';
}
}
}
$theMsg =~ s/ $param{'ident'}\'?s / my /ig;
$theMsg =~ s/^$safeWho\'?s /$safeWho, your /i;
$theMsg =~ s/ $safeWho\'?s / your /ig;
}
if (1)
{
# $date, $time
$curDate = scalar(localtime());
chomp $curDate;
$curDate =~ s/\:\d+(\s+\w+)\s+\d+$/$1/;
$theMsg =~ s/\$date/$curDate/gi;
$curDate =~ s/\w+\s+\w+\s+\d+\s+//;
$theMsg =~ s/\$time/$curDate/gi;
}
$theMsg =~ s/\$who/$who/gi;
if (1)
{
# variables. like $me or \me
$theMsg =~ s/(\\){1,}([^\s\\]+)/$1/g;
}
$theMsg =~ s/^\s*//;
$theMsg =~ s/\s+$//;
if ($param{'filter'})
{
require "src/filter.pl";
$theMsg = &filter($theMsg);
}
$theMsg;
}
1;
|
|
|
0.44.2
Added USAir flight information: 'usair flight 781'. requires LWP.
This should be replaced with a more general one.
Added keyed channel patch from Eden Li (tile).
Added new slashdot headline retrieval code care of Richard Hoelscher
(Rahga). It makes Chris Tessone's code go to the XML file on /.
Also restricted its recongized form to "slashdot" or "slashdot
headlines". Now called "Slashdot3".
Added a factpack on Security to factopacks/ submitted by Peter
Johnson (rottz), and one that has all the ports listed for tcp
and udp from Samy Kamkar (CommPort5). Keep it up! :)
Applied a patch to the insult server code from michael@limit.org.
should fix the function as well as "insult x in german".
btw, i can't send email to limit.org, so i hope he sees this :)
Modified METAR code from Lazarus Long <lazarus@frontiernet.net>
and added a status line so it tells the owner it requires
LWP and Geo::METAR.
Added Simon Cozens' Google search. Requires WWW::Search::Google.
"google for foo", "search google for foo".
Expanded the Google search to do everything WWW::Search knows about,
and to fork so it wouldn't block the bot. Dejanews, Google,
Gopher, Excite, Infoseek, HotBot, Lycos, AltaVista, Magellan,
PLweb, SFgate, and Verity. try 'search <engine> for <keywords>'.
But you really need to install WWW::Search to use this.
Added "shut up" (which changes Addressing to "REQUIRE"),
"wake up" (changes it to "OPTIONAL"), and "showmode" that
tells which mode it's in. Aldebaran++ for this. the param
"shutup" controls whether this is on; turn it off if you always
want it to be REQUIRE.
Made the output of "seen" nicer; reports how long it's been.
By the way, the Nickometer code is due to Adam Spiers, and it
was one of the earlier, relatively undocumented add-ons that
made an example for others to start off with. Added comment.
0.44.1
Fixed the CTCP bug which people were exploiting to crash. Thanks!
Wrapped the babelfish translation code 'use's in evals so
lack of URI::Escape won't stop you from running the bot.
Added Chris Tessone's slashdot headlines module with a few minor
changes (the same eval trick as above).
Added some documentation to infobot_guide.html (gasp!)
Added some factpacks in factpacks/ that were on the web site.
0.44.0
WARNING: many changes have been undocumented, but
i'm getting lots of requests to release the current
state -- warts and all. Here it is, 6:35 AM Jun 24 99,
an hour before yapc 99 opens.
many small things, as usual.
babel code (jdf++) for using babelfish to translate
things. 'translate to german: hello'. this
can be shortened to 'x to de hello'. *note:
LWP must be installed for this to work.
'insult server' code; probably not very useful.
Also requires LWP.
0.43.6
freeside++ for code to clean up the imbd redirect.
fimmtiu++ for 'your' patches. blame him now.
fixed the text of the foldoc redirect (TorgoX++)
added passwords for servers with passwords (ksiero++)
including server_pass in infobot.config
made s/// case-insensetive (mendel++)
added vhost support and vhost_name to infobot.config (elph++)
changed some trivial status messages to be prettier
made miscdir fully qualified, and changed it to ./files in
the default infobot.config file.
moved stray help setup code into a subroutine and call it
from Setup.pl
added "say" for +o (/msg <botname> say #channel foo)
made it so that +o can make the bot join any channel
added NOAA.pl, inspired by geniusj's sh script
to myRoutines.pl
added METAR support (mendel++ for metar.pl), and this
plus the weather routine make nice examples
0.43.5
added <action> as a species of <reply>: X is <action> foo!
added murrayb++'s patches for an ignore list file
made help path relative (also murrayb++)
renamed "scripts/make_db" to "scripts/update_db"
added "scripts/unupdate_dbs" to back out all changes by nick
from a log file or part of a log file. good for removing
vandalism.
made 'forget' logging more friendly to reversing it
moved all the setup stuff more cleanly into Setup.pl
made the ignore list modifiab;e at run-time with the P flag
and added 'ignore' and 'unignore' commands via msg
added substitutions: X =~ s/A/B/
0.43.4
made private messages not respoken under the persistant
"seen" -- this was allowing people to get private
information on 0.43.3. 0.43.3 was only available for
a few hours, so i hope this impact is minimal.
0.43.3
many undocumented little things. fixes, of course!
fixed the reply after seen.
made seen persistant. added the infobot.config line 'seen'
for the seen-db location
added what the last thing seen was.
made the karma path fully specified.
0.43.2
fixed the learning from other bots based on URL policy
0.43.1
minor fixes here and there.
fixed the math bug (finally! i think!)
several NL patches. Small CTCP fix.
some statement and question changes. nothing major.
wanted to get this version out before i tried getting
things working on a few more platforms. seems
pretty stable.
0.43.0
* UPDATE YOUR irc.params to infobot.config FILES *
* UPDATE YOUR userfile.txt files to infobot.users FILES *
* SOME DOCUMENTATION is now in doc/infobot_guide.html
changed DEBUG parameter name to VERBOSITY
removed the broken STANDALONE mode for now
and eviscerated the code for it
removed some lint from the params file
files/irc.params IS NOW CALLED files/infobot.config
removed vestigial paramdbm code.
removed MacOS-specific code. this needs-writing.
fixed the "out-loud" comment "you are not a bot owner"
to be silent
removed the vesitigial and misleading infobot.doc
and created some documentation ! in doc/infobot.html
and children
renamed userfile.txt to files/infobot.users
added variable interpolation to infobot.config so
you can use $ident and all previously-defined
parameter values in the assignent of subsequent
paramters.
moved userfile diagnostics into User.pl (!) from
top level infobot script
renamed crontab.infobot to infobot.crontab
converted all prints to status() for uniform logging
and console output
removed other vesitigal logging code (Log.pl)
redid the ansi color by type and status
made internic reply via msg only
removed MLF's -- these need rewriting
moved the addressing code ALL out of Irc*.pl
cleared initial negative on statements when the entry
doesn't yet exist (less weird factoids)
added 'also |' to add disjuncts easily
allowed coherent protection of any word from
processing using \. e.g. \is for
x \is y is y
added %channels, %seen, %verified hashes
added password + hostmask protection and command-on-request
with the syntax /msg <bot> <password> <command>
where <command> is {eval (mode e), op (mode p), die (mode o)}
previously public bot commands are now private message only or
privmsg + password
added "sane" files (sane-is.txt amd sane-are.txt) that
will be loaded into the -is and -are dbs at startup
and will set some items to sane values. put things
that you want to be permanent in these.
isolated statement rejection code
moved math into Math.pl
moved search code into Search.pl
rolled the requires in the top level script into a
single loop that automatically loads all the perl
files in the src directory
fixed the interaction between addressing and volunteering.
minVolunteerLength applies only if addressing is not REQUIRED
fixed the grotty math bug in perlMath that prevented negative
numbers from evalling properly
0.42.1
made it go for the _first_ verb rather than
the first verb in the list. cleaned up the
debug info.
fixed the underscore-erasing bug.
there was a problem is \b$verb\b missing
things like .is; fixed.
karma fix... allow "me", tolerate whitespace
(thanks fimmtiu and SirGawain)
0.42
fixed an interaction between marked questions,
minimum volunteering length, and addressing.
allowed talk between friendly bots
rationalized some of the logging, so you can see
who did everything ('is also' updates, in
particular).
fixed the traceroute calling syntax
for some, karma didn't work with 0.41.5; it may now :)
0.41.5
closed the traceroute hole
fixed the reverse DNS
fixed some 'huh?' replies -- made sure to return
the NOREPLY token in Update.pl
* desire: cut confirmation replies (mode)
* desire: silent mode (learn only)
rev 0.41.0 - 0.41.4
many minor things, mostly natural language,
some infrastructure. allowed "forget" to
end with final punctuation.
added factpack subdirectory. use these to
load up the bot with things. more to come.
fixed "addressing" -> REQUIRE.
revision 0.41
added "karma". now "x++" or "x--" will change x's karma.
"karma for x" will show it's current standing. This
idea came from dkindred@cs.cmu.edu and his plusplus
Zephyr bot. Darrel Kindred is the mastermind here;
I just liked the idea and added it.
added e mode in userfile to expose eval. this is not
recommended. requires a crypted pass, then
/msg bot <pass> eval <perl code>
revision 0.40.1
replaced default userfile and fixed a tiny bit of NL where
it would say "OK" even when X already was Y.
the next rev will be the one for MacPerl etc., i hope. this
was just a quick fix because 0.40 wasn't letting people
teach by default.
revision 0.40
several small fixes -- fixed a big with article deletion,
made it so it doesn't echo when told to die by a non-master,
fixed a few NL things, removed the CTCP die command.
Mailing list opens.
I plan one more rev to make sure this pre-version works
with MacPerl, then we'll switch to the new model.
revision 0.39
integrated wf's changes with my own NL stuff from
purl exploits. this is a quick-turnaround rev to
get things in place for an upcoming major rev.
since nslookup, etc are now keyworded, removed
ipmatch and dmatch regexen from their preconditions.
added param for default signoff message
revision 0.38
user system reworked flags are settable to limit
access to the bot's features. Examples can
be found in files/userfile.txt.
non-blocking sockets added to allow use of DCC
and other various functions to come soon.
revision 0.37
Standalone mode works again after an oops in the
hooks by wildy... :)
revision 0.36
NL stuff, some fixes from purl.
revision 0.35
new option; multiline factoids. you can use the
following syntax to teach infobot facts on
multiple lines:
<mynick> infobot: something is <multi>
anything said from there on will be recorded
as part of the fact. make sure you designate
the end of the fact or it will continue adding
everything you say into the fact.
<mynick> <end>
this will end the fact and store it in the db.
made MLFs work with repeatIgnoreInterval to prevent
some nasty abuse potential; added status
line for repeat ignore
revision 0.34
fixed the addressing bug found in Irc.pl
removed the "okay" message when it doesn't replace
a key with the same message; this makes it nicer
when more than one is on the same channel, though
they still all reply
changed the default params to make urls optional
fixed the "the" bug, and expanded the "can" grammar
to handle cases more flexibly.
undid some bug that were introduced in handing the
code back and forth
folded in code that got out of sync in parallel revs.
revision 0.33.3
added the formatting of public channel messages and
changed the hook code to be a bit more sane
revision 0.33.2
re changed infobot to OPTIONAL listening/learning
instead of just url's as default
revision 0.33.1
added a few irc operator things in param file
fixed the math routines
commented out the dotwise domain thing in Question.pl
because its regex didn't function correctly, etc
maybe just use the one nslookup so it doesnt get
confused with messages.
cleaned up for a hopefully stable-ish 0.33
revision 0.32b
infobot doesn't require perl 5.004 anymore, you
can run safely with perl 5.001 i'm pretty sure.
added support for ANSI Color -- enjoy, you
can turn this on/off in the params file. also
might ansi-fy a few more parts. not much though.
fixed bugs with irc code where infobot
couldn't join &channels (local) or channels
with weird things like '!'.
-patrick
fixed the :) bug
fixed non-default param file to files/irc.params
-kevin
revision 0.31b
ok, reintegrating the irc modules.
re-added $nuh support so that users can use their
passwords, etc.
made numbers with more than 16 digits "a very big
number" in the math handling.
it's indentation wars! now that the tabs are gone,
most things indent nicely.
cut out a few vestigial lines from the inlet code,
such as the hard-coded dbs (not used now anyway).
i'm still torn about the copyright/license thing. have
to figure out how to handle that.
changed the default nick back the Newbie.
removed the #$%#$% param db that was bugging me so
much. just read in the param file and be
happy.
renamed "run_infobots.pl" to "run_if_needed.pl" and
made a couple of minor changes in it.
revision 0.30b
thanks, patrick! Patrick Cole (wildfire) did
everything for rev 029b... many many thanks.
made the irc version the default
changed the default server to cmu
changed the default channel to #infobot
will do more in the near future...
NOTE infobot now requires perl 5.004
revision 0.29b
the first and greatest appearance of the inlet code rolled
into infobot. new look makes it easier to see what's
going on and gives it a greater feel to it. All irc
code rewritten by Patrick Cole graciously
added a traceroute command for lazy people, etc
nslookup for domain lookups
reindented all the code by hand (ugh) because it was in an
"Eight Megs and Constantly Swapping" kind of way :)
infobot can now reconnect split servers ...
"/ctcp infobot autorecon on"
internic whois querys should work now hopefully
revision 0.28b
the first appearance of "curl", the command-line url.
useful for one-line queries and updates of the db.
not as full-featured as the standalone url --
these will probably merge.
fixed a minor bug in writeParamFile
woops. it was set to userLevel > 100 for the eval
instead of >= 100.
revision 0.27b
aha! there was a bug in the argument parser; used pop
instead of shift. this ought to work better now.
added absolute path to url in in4m. use this if you're
going to invoke url from anywhere other than the
home directory.
cleaned up in4m (top level) somewhat
added mkpasswd and ckpasswd in anticipation of userlevels
added writeParamFile in urlParams.pl. I still would like
to get away from the param db and just read and write
a flat file.
allowed $date, $time variables in values, e.g. "date is $date"
allowed \i \me \my in values that prevents "person-switching",
e.g. "x is go ahead and tell \me" so it doesn't turn me
into "in4m" or whatever on output
moved $safeWho generation into &purifyNick, which makes a
nick safe to use in a regex (among other things). it
really just removes 'bad' characters.
lifted the 'forget' code above most of the text processing
so it's more wysiwyf ('what you see is what you forget').
stamped out what i hope is the last nick bracket bug
lifted the normalize query and switch person calls into urlQuestion
so that they don't cause weird interaction problems
fixed a bug in 'you' (in switchPerson) referring to the bot
added a 'chomp' on reading init files to keep out extra \n's
added more stuff in urlUser.pl
removed the secretWord potential nightmare and replaced it
with the userlist potential nightmare
addusers, readUserFile, writeUserFile, ckuser, users, etc
etc. in urlUser.pl
userList parameter in irc.params, standalone.params
userlevel 100 exposes eval (!), userlevel 10 lets you
override the 'REQUIRE' option for urls. come to
think of it, REQUIRE could be a number...
allowed 'allowUrls' to be a number, in which case it is
interpreted as the min userlevel to enter a non-url
revision 0.26b
added a '<reply>' prepended tag to allow simple responses
(thanks, scuzzi_)
made the default behaviour not to whine about things that
are already defined (...but x is y...) unless addressed
which makes it nicer when more than one are on the same
channel
revision 0.25b
mucked around with run_infobots.pl to get it working with
cron more obviously
urlProcess had an old-style %params ; changed to %param
moved a check for null paramfile names into loadParams loop
fixed a bracketing error that led to irc mode overriding
made it optional to use the parameter dbm; it's actually
reasonable to just read the irc.params file only
and not go for the "persistant parameters"
revision 0.24b
added a "commitDBM every Nth transaction" form of the parameter
made dbm retry 10 times to open if it fails
changed the default standalone params to point to the right files dir
added a 'usage' output to dump_db to match make_db
added param allowLeave, which lets people make the bot leave a chan
changed the top-level name to just in4m.
added args to the command line: -p, -i, -s, -h
added a src/myRoutines.pl file so people can customize easily
revision 0.23b
fixed dump_db :/ silly me
fixed another little problem in urlDBM.pl
revision 0.22b
set up params as a db. it's still a hack and needs work,
but it allows for persistant params that you can set
within a session.
fixed various problems in referring to the right dbs
removed gratuitous accesses to the dbs
exposed more stuff in the standalone version. see standalone.txt.
set up initialization of dbs within in4m.pl
removed RUN_ME_FIRST
changed %params to %param to make set look nicer
moved make_db and dump_db into scripts/ subdir
and cleaned them up slightly
renamed params/ to files/
made a doc dir and put the README for standalone in there
added 'where is x at' form (thanks, scuzzi)
revision 0.21b
got rid of the question count access to the db.
made -w happier. someday i'll make -s happy too.
added parameter files to make life better.
the first appearance of the standalone desktop interactive
version that doesn't depend on irc.
added params and hooks for the standalone version.
params{nick} behaviour made consistant (urlSetup was overriding).
@allowed_channels fixed to $params{'allowed_channels'}.
fixed the if (($params{'addressing'} eq 'REQUIRE') && $addressed)
to !addressed in urlStatement (thanks again, cburnett).
made it open and close dbm files on each update unless
told otherwise. some implementations did not guarantee
commit. you can check your implementation and set
this to null or something else if you have a smart dbm.
added params for maxKeyLength and maxDataLength.
added params and fixed the help files. help files are
still ugly in the standalone mode.
added allowUpdate parameter so you can have strictly answerbots;
this will tie in to having restricted lists of users + levels.
made it so by default the irc version has no output. turn
up the debug level if you need more insight into what's
going in.
revision 0.20b
this was a quick rev.
fixed some of the gratuitous named stuff in urlProcess.pl
made it so dns wouldn't try to fork under macperl
got the tracking back up
revision 0.19b:
changed the default db's to be infobot-is and infobot-are
changed RUN_ME_FIRST to deal with that and renamed the .txt files
made a wantNick param
make it so dbs are created if don't exist (as option)
fixed $addressed so it didn't just look for prefixes
fixed a couple of the parameters that weren't referring to the hash
changed $urlCount to $factoidCount
revision 0.18b:
moved a bunch of params into the global hash %params
added ¶ms so people can see the settings
e.g. /msg in4m mysecretword ¶ms();
added some parameters up-front for server, port, etc.
changed the bad nickname code
the burnett fix (:$realname)
added infobot.help as a default help file
|
|
|
#!/usr/bin/perl
# you will probably need to change $homedir
# and possibly the path to perl above
my $homedir = '/usr/home/infobot/infobot0.34';
my @ps = `ps auxw`;
@result = grep !/grep/, @ps;
@result = grep /infobot/, @ps;
if (!@result) {
print "trying to run new process\n";
chdir($homedir) || die "can't chdir to $homedir";
system("nohup $homedir/infobot -i $homedir/files/irc.params > /dev/null &");
} else {
print "already running: \n";
print " @result\n";
}
|
|
|
# infobot copyright kevin lenzo 1997-1998
sub search {
my $pattern = $_[0];
if (0 & $addressed && ($msgType ne 'dcc_chat')) {
&msg($who, "this search requires dcc chat. /dcc chat $nick and then try again.");
return 'NOREPLY';
} else {
if ($pattern =~ s/^\d+ //) {
$bail_thresh = $&;
} else {
$bail_thresh = 10;
}
$pattern =~ s/\?+\s*$//;
return "" if ($pattern =~ /^\s*$/);
my $MINL = 3;
return "that pattern's too short. try something with at least $MINL characters." if (length($pattern) < $MINL);
&msg($who,"Looking for $pattern:");
my (@response, $bail, $perfect);
my (@myIsKeys) = getDBMKeys("is");
my (@myAreKeys) = getDBMKeys("are");
foreach (@myIsKeys) {
if ($_ =~ /^$pattern$/) {
$r = &get("is", $_);
$perfect = "$_ is $r";
last if ($in =~ /^\s*scan/i);
next;
}
if ($_ =~ /$pattern/) {
$r = &get("is", $_);
push(@response, "$_ is $r")
unless ++$bail > $bail_thresh;
last if ($in =~ /\s*scan/i);
}
}
if (($in =~ /search/) || (!$perfect)) {
foreach (@myAreKeys) {
if ($_ =~ /^$pattern$/) {
$perfect .= "; " if $perfect;
$r = &get("are", $_);
$perfect .= "$_ are $r";
last if ($in =~ /^\s*scan/i);
next;
}
if ($_ =~ /$pattern/) {
$r = &get("are", $_);
push(@response, "$_ are $r")
unless ++$bail > $bail_thresh;
last if ($in =~ /^\s*scan/i);
}
}
}
if ((@response == 0) && (!$perfect)) {
return "nothing";
} else {
foreach (@response) {
&msg($who, $_);
}
if ($bail > $bail_thresh) {
&msg($who," ...showing first $bail_thresh hash table hits.");
}
return "$perfect" if ($perfect);
if (($in =~ /\s*scan/i) && ($bail > 0)) {
return " ...scan hit; terminated";
}
undef(@response);
return " ";
}
return " ";
}
}
1;
|
|
|
# infobot :: Kevin Lenzo (c) 1997
sub setup {
# param setup should stay after most of the requires
# so that it overrides anything they might set.
¶mSetup();
if ($param{VERBOSITY} > 1) {
my $params = "Parameters are:\n";
foreach (sort keys %param) {
$params .= " $_ -> $param{$_}\n";
}
&status($params);
}
die "dbname is null" if (!$param{'dbname'});
%dbs = ("is" => "$infobot_base_dir/$param{dbname}-is",
"are" => "$infobot_base_dir/$param{dbname}-are");
srand();
$setup_time = scalar(localtime());
$setup_time =~ s/\n//g;
$startTime = time();
&setup_help;
&openDBM(%dbs);
$qCount = &get("is", "the qCount");
$qEpochTime = &get("is", "the qEpochTime");
# things to say when people thank me
@welcomes = ('no problem', 'my pleasure', 'sure thing',
'no worries', 'de nada', 'de rien', 'bitte', 'pas de quoi');
# when i'm cofused and I have to reply
@confused = ("huh?",
"what?",
"sorry...",
"i\'m not following you...",
"excuse me?");
# when i recognize a query but can't answer it
@dunno = ('i don\'t know',
'wish i knew',
'i haven\'t a clue',
'no idea',
'bugger all, i dunno');
# check the ignore parameter for a filename containing the
# ignore list
if ($param{ignore}) {
if (!dbmopen(%ignoreList, "$infobot_base_dir/$param{ignore}", 0655)) {
&status("Can't open ignore dbm $param{ignore}: $!");
} else {
&status("Opened ignore dbm $param{ignore}");
}
}
if ($param{sanePrefix}) {
for $d (qw/is are/) {
my $dbname = $DBprefix.$d;
my $sane = "$param{miscdir}/$param{sanePrefix}";
$sane .= "-$d.txt";
if (-e $sane) {
&status("loading sane defines $sane");
&insertFile($sane, $dbname);
} else {
&status("can't fine sane file $sane");
}
}
if (! open IGNORE, "$param{'miscdir'}/$param{sanePrefix}-ignore.txt") {
&status("No fallback ignore file $param{'miscdir'}/$param{sanePrefix}-ignore.txt");
} else {
while (<IGNORE>) {
s/^\s+//;
s/\s+\#.*//;
chomp;
/\S/ && do {
$ignoreList{$_}++;
if ($param{'VERBOSITY'} > 0) {
&status("Adding $_ to ignore list (from sane).");
}
};
}
close IGNORE;
}
}
if ($param{'plusplus'}) {
$plusplus = $infobot_base_dir.$filesep.$param{'plusplus'};
if (!dbmopen(%plusplus, $plusplus, 0644)) {
&status("Can't open karma db $plusplus");
} else {
&status("Opened karma db $plusplus");
}
}
if ($param{'seen'}) {
$seen_db = $infobot_base_dir.$filesep.$param{'seen'};
if (!dbmopen(%seen, $seen_db, 0644)) {
&status("Can't open seen db $seen_db");
} else {
&status("Opened seen db $seen_db");
}
}
# set up the users and ops
&parseUserfile();
# ways to say hello
@hello = ('hello',
'hi',
'hey',
'niihau',
'bonjour',
'hola',
'salut',
'que tal',
'privet',
"what's up");
$param{'maxKeySize'} ||= 30; # maximum LHS length
$param{'maxDataSize'} ||= 200; # maximum total length
if (!defined(@verb)) {
@verb = split(" ", "is are");
# am was were does has can wants needs feels
# handle s-v agreement for non-being verbs later
}
if (!defined(@qWord)) {
@qWord = split(" ", "what where who"); # why how when
}
# do this ONCE per startup to amortize. Still too much mem.
#&getAllKeys;
$isCount = &getDBMKeys('is');
$areCount = &getDBMKeys('are');
$factoidCount = $isCount + $areCount;
&status("setup: $factoidCount factoids; $isCount IS; $areCount ARE");
}
sub paramSetup {
my $initdebug = 1;
$param{'DEBUG'} = $initdebug;
if (!@paramfiles) {
# if there is no list of param files, just go for the default
# (usually ./files/infobot.config)
@paramfiles = ("$initmiscdir/infobot.config");
}
# now read in the parameter files
&loadParamFiles(@paramfiles);
}
1;
|
|
|
#####################
# #
# Slashdot.pl for #
# SlashDot headline #
# retrival #
# tessone@imsa.edu #
# Chris Tessone #
# Licensing: #
# Artistic License #
# (as perl itself) #
#####################
#fixed up to use XML'd /. backdoor 7/31 by richardh@rahga.com
#My only request if this gets included in infobot is that the
#other header gets trimmed to 2 lines, dump the fluff ;) -rah
#added a status message so people know to install LWP - oznoid
#also simplified the return code because it wasn't working.
use strict;
my $no_slashlines;
BEGIN {
$no_slashlines = 0;
eval "use LWP::UserAgent";
$no_slashlines++ if $@;
}
sub getslashdotheads {
# configure
if ($no_slashlines) {
&status("slashdot headlines requires LWP to be installed");
return '';
}
my $ua = new LWP::UserAgent;
$ua->timeout(12);
my $maxheadlines=5;
my $slashurl='http://www.slashdot.org/slashdot.xml';
my $story=0;
my $slashindex = new HTTP::Request('GET',$slashurl);
my $response = $ua->request($slashindex);
if ($response->is_success) {
$response->content =~ /<time>(.*?)<\/time>/;
my $lastupdate=$1;
my $headlines = "Slashdot - Updated ".$lastupdate;
my @indexhtml = split(/\n/,$response->content);
# gonna read in this xml stuff.
foreach(@indexhtml) {
if (/<story>/){$story++;}
elsif (/<title>(.*?)<\/title>/){
$headlines .= " | $1";
}
elsif (/<url>(.*?)<\/url>/){
# do nothing
}
elsif (/<time>(.*?)<\/time>/){
# do nothing
}
last if $story >= $maxheadlines;
next;
}
return $headlines;
} else {
return "I can't find the headlines.";
}
}
1;
|
|
|
# infobot :: Kevin Lenzo (c) 1997
# doce++ for the first version of this!
sub ispell {
my $in = $_[0];
$in =~ s/^\s+//;
$in =~ s/\s+$//;
return "$in looks funny" unless $in =~ /^\w+$/;
#derr@rostrum# ispell -a
#@(#) International Ispell Version 3.1.20 10/10/95
#peice
#& peice 4 0: peace, pence, piece, price
my @tr = `echo $in | ispell -a -S`;
if (grep /^\*/, @tr) {
my $result = "'$in' may be spelled correctly";
if ($msgType =~ /private/) {
&msg($who, $result);
} else {
&say("$who: $result");
}
} else {
@tr = grep /^\s*&/, @tr;
chomp $tr[0];
($junk, $word, $junk, $junk, @rest) = split(/\ |\,\ /,$tr[0]);
my $result = "Possible spellings for $in: @rest";
if (scalar(@rest) == 0) {
$result = "I can't find alternate spellings for '$in'";
}
if ($msgType =~ /private/) {
&msg($who, $result);
} else {
&say($result);
}
}
return '';
}
1;
|
|
|
# infobot :: Kevin Lenzo (c) 1997
##
## doStatement --
##
## decide if $in is a statement, and if so,
## - update the dbm
## - return feedback statement
##
## otherwise return null.
##
sub doStatement {
return '' if (lc($who) eq lc($param{'nick'}));
my($msgType, $in) = @_;
$in =~ s/\\(\S+)/\#$1\#/g;
# switch person
$in =~ s/(^|\s)i am /$1$who is /i;
$in =~ s/(^|\s)my /$1$who\'s /ig;
$in =~ s/(^|\s)your /$1$param{'ident'}\'s /ig;
if ($addressed) {
$in =~ s/(^|\s)you are /$1$param{'ident'} is /i;
}
$in =~ s/^no,\s+//i; # don't want to complain if it's new but negative
if ($param{'plusplus'}) {
$in =~ s/(--|\+\+)(\(.*?\)|\S+)/$2$1/;
if ($in =~ /(\(.*?\)|\S+)(\+\+|--)/) {
my($term,$inc) = ($1,$2);
$term = lc($term);
# try to normalize phrases
$term =~ s/^\((.*)\)$/$1/;
$term =~ s/\s+/ /g;
if ($msgType !~ /public/i) {
&msg($who, "karma must be done in public!");
return "NOREPLY";
}
if (lc($term) eq lc($who)) {
&msg($who, "please don't karma yourself");
return 'NOREPLY';
}
if ($inc eq '++') {
$plusplus{$term}++;
} elsif ($inc eq '--') {
$plusplus{$term}--;
}
return 'NOREPLY';
}
}
my($theType);
my($lhs, $mhs, $rhs); # left hand side, uh.. middlehand side...
# the unignore hack...
# if we see this word, unignore all
if ($in =~ /$param{'unignoreWord'}/i) {
undef %ignoreList;
&status("unignoring all ($who said the word)");
}
# check if we need to be addressed and if we are
if (($param{'addressing'} eq 'REQUIRE') && !$addressed) {
return 'NOREPLY';
}
# prefix www with http:// and ftp with ftp://
$in =~ s/ www\./ http:\/\/www\./ig;
$in =~ s/ ftp\./ ftp:\/\/ftp\./ig;
# look for a "type nugget". this should be externalized.
$theType = "";
$theType = "mailto" if ($in =~ /\bmailto:.+\@.+\..{2,}/i);
$theType = "mailto" if ($in =~ s/\b(\S+\@\S+\.\S{2,})/mailto:$1/gi);
$in =~ s/(mailto:)+/mailto:/g;
$theType = "about" if ($in =~ /\babout:/i);
$theType = 'afp' if ($in =~ /\bafp:/);
$theType = 'file' if ($in =~ /\bfile:/);
$theType = 'palace' if ($in =~ /\bpalace:/);
$theType = 'phoneto' if ($in =~ /\bphone(to)?:/);
if ($in =~ /\b(news|http|ftp|gopher|telnet):\s*\/\/[\-\w]+(\.[\-\w]+)+/) {
$theType = $1;
}
# here's where you set the behaviour.
if (($param{'acceptUrl'} =~ /\d+/) && $addressed
&& ($param{'acceptUrl'} < $theUserLevel)) {
} else {
if ($param{'acceptUrl'} eq 'REQUIRE') {
# require url type.
# &status("REJECTED non-URL entry") if ($param{VERBOSITY});
return 'NOREPLY' if ($theType eq "");
} elsif ($param{'acceptUrl'} eq 'REJECT') {
&status("REJECTED URL entry") if ($param{VERBOSITY});
return 'NOREPLY' unless ($theType eq "");
} else {
# OPTIONAL
# you could put another filter here
}
}
# report status somewhere is we're doing that
&status("type $theType: $in") if $theType;
foreach $item (@verb) { # check for verb
if ($in =~ /(^|\s)$item(\s|$)/i) {
($lhs, $mhs, $rhs) = ($`, $&, $');
$lhs =~ tr/A-Z/a-z/;
$lhs =~ s/^\s*(the|da|an?)\s+//i; # discard article
$lhs =~ s/^\s*(.*?)\s*$/$1/;
$mhs =~ s/^\s*(.*?)\s*$/$1/;
$rhs =~ s/^\s*(.*?)\s*$/$1/;
# note : prevent access to globals in the eval
return '' unless ($lhs and $rhs);
return "The key is too long (> $param{maxKeySize} chars)."
if (length($lhs) > $param{maxKeySize});
if (length($message) > $param{'maxDataSize'}) {
if ($msgType =~ /public/) {
if ($addressed) {
if (rand() > 0.5) {
&performSay("that entry is too long, ".$who);
} else {
&performSay("i'm sorry, but that entry is too long, $who");
}
}
} else {
&msg($who, "The text is too long");
}
return '';
}
return 'NOREPLY' if ($lhs eq 'NOREPLY');
my $failed = 0;
$lhs =~ /^(who|what|when|where|why|how)$/ and $failed++;
if (!$failed and !$addressed) {
# the arsenal of things to ignore if we aren't addressed directly
$lhs =~ /^(who|what|when|where|why|how|it) /i and $failed++;
$lhs =~ /^(this|that|these|those|they|you) /i and $failed++;
$lhs =~ /^(every(one|body)|we) /i and $failed++;
$lhs =~ /^\s*\*/ and $failed++; # server message
$lhs =~ /^\s*<+[-=]+/ and $failed++; # <--- arrows
$lhs =~ /^[\[<\(]\w+[\]>\)]/ and $failed++; # [nick] from bots
$lhs =~ /^heya?,? / and $failed++; # greetings
$lhs =~ /^\s*th(is|at|ere|ese|ose|ey)/i and $failed++; # contextless
$lhs =~ /^\s*it\'?s?\W/i and $failed++; # contextless clitic
$lhs =~ /^\s*if /i and $failed++; # hypothetical
$lhs =~ /^\s*how\W/i and $failed++; # too much trouble for now
$lhs =~ /^\s*why\W/i and $failed++; # too much trouble for now
$lhs =~ /^\s*h(is|er) /i and $failed++; # her name is
$lhs =~ /^\s*\D[\d\w]*\.{2,}/ and $failed++; # x...
$lhs =~ /^\s*so is/i and $failed++; # so is (no referent)
$lhs =~ /^\s*s+o+r+[ye]+\b/i and $failed++; # sorry
$lhs =~ /^\s*supposedly/i and $failed++;
$lhs =~ /^all / and $failed++; # all you have to do, all you guys...
} elsif (!$failed and $addressed) {
# things to skip if we ARE addressed
}
if ($failed) {
&status("statement: IGNORED <$who> $message");
return 'NOREPLY';
}
&status("statement: <$who> $message");
$lhs =~ s/\#(\S+)\#/$1/g;
$rhs =~ s/\#(\S+)\#/$1/g;
$lhs =~ s/\?+\s*$//; # strip the ? off the key
$lhs = &update($lhs, $mhs, $rhs);
return 'NOREPLY' if ($lhs eq 'NOREPLY');
last;
}
}
$lhs;
}
1;
|
|
|
copy \temp\badx.pl \temp\x.pl
call prettypl \temp\x.pl
|
|
|
# infobot :: Kevin Lenzo & Patrick Cole (c) 1997
#use POSIX;
#
#sub T_REAPER
# {
# $SIG{CHLD} = \&REAPER; # loathe sysV
# $waitedpid = wait;
# }
#
#$SIG{CHLD} = \&T_REAPER;
sub troute
{
my $in = $_[0];
# if (!defined($pid = fork))
# {
# return "no luck, $safeWho";
# }
# elsif ($pid)
# {
# # parent
# }
# else
{
# child
if ($in !~ /^[-_a-zA-Z0-9]+(\.[-_a-zA-Z0-9]+)+$/)
{
&status("malformed traceroute: :$in:\n");
&msg($who, "I don't understand your traceroute '$in'");
# exit;
return; #jaa
}
my @tr = `tracert.exe $in`;
&msg($who, "there are " . scalar @tr . " lines in the traceroute for '$in'");
my $out;
foreach $out (@tr)
{
chomp $out;
&msg($who, $out);
}
# chomp($out = $tr[@tr-1]);
# if ($msgType eq 'public')
# {
# &msg($who, $out);
# # &say($out);
# }
# else
# {
# &msg($who, $out);
# }
# # exit; # kill child
}
}
1;
|
|
|
#!/usr/bin/perl
if (@ARGV != 1) {
print "\n";
print " Usage: $0 <file.track>";
print "\n";
print " generates text files for make_db from\n";
print " the tracking file log.\n";
print "\n";
print " creates <file.track>-is.txt and \n";
print " <file.track>-are.txt\n";
print "\n";
}
foreach $file (@ARGV) {
if (!open IN, $file) {
print "can't open $file: $!\n";
next;
}
open IS, ">$file-is.txt";
open ARE, ">$file-are.txt";
while (<IN>) {
chomp;
if (s/.*?enter: \S+ said \'(.*)\'/$1/
or s/.*?update: \'(.*?)\'; was .*/$1/) {
if (/^(.*?) is (.*)/) {
print IS "$1 => $2\n";
} elsif (/^(.*?) are (.*)/) {
print ARE "$1 => $2\n";
}
} else {
# do nothing
}
}
close IN;
close IS;
close ARE;
}
|
|
|
#!/usr/bin/perl
package UAFlight;
use strict;
my $no_usair;
BEGIN {
eval "use HTTP::Request::Common qw(POST)";
$@ and $no_usair++;
eval "use LWP::UserAgent";
$@ and $no_usair++;
}
sub get_ua_flight_status {
my ($flt_num, $day, $month) = @_;
return 'unsupported: requires HTTP::Request and LWP::UserAgent' if $no_usair;
my $ua = new LWP::UserAgent;
my ($wkday, $tmonth, $tday, $time, $year) = split /\s+/, localtime;
$day = $tday unless $day;
$month = $tmonth unless $month;
my $req = POST 'http://dps1.usairways.com/cgi-bin/fi',
[ FltNum => $flt_num, month => $month, day => $day, page => 'fi', x => 20, y => 23 ];
return &parse_ua_flt( $ua->request($req)->as_string)."\n";
}
sub parse_ua_flt {
my $data = join '', @_;
my ($airline, $flight_num, $date, $retval, $time);
my ($dep_city, $est_dep_time, $actual_dep_time, $arr_city, $est_arr_time, $actual_arr_time, $arr_time, $s_dep_city, $s_dep_time, $s_bag_claim, $s_dep_gate, $s_arr_city, $s_arr_time, $s_arr_gate, $s_baggage);
$data =~ s/^.*Airline:.*?\n//gs;
$data =~ s/^(.*?)<.*\n// and $airline = $1;
$data =~ s/^.*Flight Number:.*?\n//gs;
$data =~ s/^(.*?)<.*\n// and $flight_num = $1;
$data =~ s/^.*Date of Information:.*?\n//gs;
$data =~ s/^(.*?)<.*\n// and $date = $1;
return "can't find that flight" unless $flight_num;
$retval = "$airline flight $flight_num on $date ";
$data =~ s/^.*Current Time:.*?\n//gs;
$data =~ s/^(.*?)<.*\n// and $time = $1;
# $retval .= "Current Time: $time\n";
# "actual flight info"
# Airport Actual Estimated Remarks
# arrival departure arrival departure
# departure
$data =~ s/^.*?<A HREF=.*?page=city\">//gs;
$data =~ s/^(.*?)<.*?\n// and $dep_city = $1;
$data =~ s/^.*\n//;
$data =~ s/^<BR>\n//; # field makes no sense - est arr at depart airport
$data =~ s/^.*\n//;
$data =~ s/^(.*)\n// and $1 ne "<BR>" and $est_dep_time = $1;
$data =~ s/^.*\n//;
$data =~ s/^<BR>\n//; # field makes no sense - actual arr at depart airport
$data =~ s/^.*\n//;
$data =~ s/^(.*)\n// and $1 ne "<BR>" and $actual_dep_time = $1;
my $actual = 0;
if ($actual_dep_time or $est_dep_time) {
# arrival
if ($actual_dep_time) {
$retval .= "left $dep_city at $actual_dep_time";
} else {
$retval .= "estimated departure from $dep_city at $est_dep_time";
}
$retval .= " ";
$data =~ s/^.*?<A HREF=.*?page=city\">//gs;
$data =~ s/^(.*?)<.*\n// and $arr_city = $1;
$data =~ s/^.*?\n//;
$data =~ s/^(.*)\n// and $1 ne "<BR>" and $est_arr_time = $1;
$data =~ s/^.*?\n//;
$data =~ s/^<BR>\n//; # est dep from arr airport?
$data =~ s/^.*\n//;
$data =~ s/^(.*)\n// and $1 ne "<BR>" and $actual_arr_time = $1;
$data =~ s/^.*?\n//;
$data =~ s/^<BR>\n//; # actual dep from arr aiport
$data =~ s/^.*?\n//;
$data =~ s/^(\S+)\s+// and $1 ne "<BR>" and $arr_time = $1;
if ($actual_arr_time =~ /\S/) {
$retval .= "arrived in $arr_city at $actual_arr_time";
} else {
$retval .= "estimated to arrive in $arr_city at $est_arr_time";
}
$actual = 1;
}
$data =~ s/^.*Scheduled Flight Information.*?\n//s;
# dep
$data =~ s/^.*?<A HREF=.*?page=city\">//gs;
$data =~ s/^(.*?)<.*\n// and $s_dep_city = $1;
$data =~ s/^.*\n//;
$data =~ s/^<BR>\n//; # field makes no sense - arr at depart airport
$data =~ s/^.*\n//;
$data =~ s/^(.*)\n// and $1 ne "<BR>" and $s_dep_time = $1;
$data =~ s/^.*\n//;
$data =~ s/^<BR>\n//; # arr gate from dep airport
$data =~ s/^.*\n//;
$data =~ s/^(.*)\n// and $1 ne "<BR>" and $s_bag_claim = $1;
$data =~ s/^.*\n//;
$data =~ s/^(.*)\n// and $1 ne "<BR>" and $s_dep_gate = $1;
# arr
$data =~ s/^.*?<A HREF=.*?page=city\">//gs;
$data =~ s/^(.*?)<.*\n// and $s_arr_city = $1;
$data =~ s/^.*\n//;
$data =~ s/^(.*)\n// and $1 ne "<BR>" and $s_arr_time = $1;
$data =~ s/^.*\n//;
$data =~ s/^<BR>\n//;
$data =~ s/^.*\n//;
$data =~ s/^(.*)\n// and $1 ne "<BR>" and $s_arr_gate = $1;
$data =~ s/^.*\n//;
$data =~ s/^(.*)\n// and $1 ne "<BR>" and $s_baggage = $1;
if (!$actual) {
$retval .= "is scheduled to leave $s_dep_city at $s_dep_time ";
$retval .= "from gate $s_dep_gate " if $s_dep_gate;
$retval .= "and arrive in $s_arr_city at $s_arr_time ";
$retval .= "at gate $s_arr_gate" if $s_arr_gate;
}
return $retval;
}
"A true value.";
|
|
|
#!/usr/bin/perl
if ((scalar(@ARGV) != 3) || (grep /^-/, @ARGV)) {
print "\n";
print " usage: $0 <logfile> <nickname> <dbmstem>\n";
print "\n";
print " undo the updates entered by nickname that appear\n";
print " in an infobot log file\n";
print "\n";
print " <logfile> is an infobot text log file\n";
print "\n";
print " <nickname> is the nickname whose effects you\n";
print " want to undo (without the brackets, of course)\n";
print "\n";
print " <dbmstem> the the basename of the dbm db\n";
print " (e.g. 'infobot-')\n";
print "\n";
exit(1);
}
($logfile, $nickname, $dbmstem) = @ARGV;
open(IN, $logfile)
|| die "can\'t open $logfile as source\n";
if (not $test = 0) {
dbmopen(%dbis, "$dbmstem-is", 0755)
|| die "Couldn't dbmopen \"$dbmstem-is\"";
dbmopen(%dbare, "$dbmstem-are", 0755)
|| die "Couldn't dbmopen \"$dbmstem-are\"";
}
$| = 1;
while (<IN>) {
chomp;
next unless s/^(\d+) \[(\d+)\] (\S+): <(\S+)> //;
@attr{qw/time entry type nick/} = ($1, $2, $3, $4);
next unless $attr{'nick'} =~ /^$nickname/i;
if ($attr{'type'} eq 'update') {
@attr{qw(X verb corrupted Y)} = /^\'(.*?) =(is|are)=> (.*?)\'; was \'(.*)\'$/;
$attr{X} =~ s/^\s*//;
$attr{X} =~ tr/A-Z/a-z/;
$attr{Y} =~ s/\s+$//;
if ($attr{verb} eq 'is') {
$dbis{$attr{X}} = $attr{Y};
} else {
$dbare{$attr{X}} = $attr{Y};
}
push @undo, "enter: $attr{X} =$attr{verb}=> $attr{Y}";
} elsif ($attr{'type'} eq 'forget') {
$attr{X} = $_;
warn "* can't handle 'forget' easily until 0.43.5: forget $_\n";
} elsif ($attr{'type'} eq 'enter') {
$attr{qw/X verb Y/} = /^(.*?) =(is|are)=> (.*)$/;
push @undo, "delete: $1 =$2=> $3";
}
}
close(IN);
while ($act = pop @undo) {
($type, $X, $verb, $Y) = $act =~ /^(\S+): (.*?) =(\S+)=> (.*)$/;
if ($type eq 'enter') {
print "ENTER $X <=$verb= $Y\n";
if ($verb eq "is") {
$dbis{$X} = $Y;
} else {
$dbare{$X} = $Y;
}
} elsif ($type eq 'delete') {
print "DELETE $X <=$verb= $Y\n";
if ($verb eq "is") {
delete $dbis{$X};
} else {
delete $dbare{$X};
}
}
}
dbmclose(%dbis);
dbmclose(%dbare);
exit;
|
|
|
# infobot :: Kevin Lenzo (c) 1997
sub update {
my($lhs, $verb, $rhs) = @_;
my($reply) = $lhs;
$lhs =~ s/^\s*=?//; # handle dcc =oznoid and stuff
$lhs =~ s/^i (heard|think) //i;
$lhs =~ s/^some(one|1|body) said //i;
$lhs =~ s/ +/ /g;
# this really needs cleaning up
if ($verb eq "is") {
$also = ($rhs =~ s/^also //i);
my $also_or = ($also and $rhs =~ s/\s*\|\s*//);
if ($exists = &get("is", $lhs)) {
chomp $exists;
if ($exists eq $rhs and not $main::googling) {
if ($msgType =~ /public/) {
&performSay("i already had it that way, $who.");
} else {
&msg($who, "it already was $rhs");
}
return 'NOREPLY';
}
$skipReply = 0;
if ($also) {
if ($also_or) {
$rhs = $exists . '|'.$rhs;
} else {
if ($exists ne $rhs) {
$rhs = $exists .' or '.$rhs;
}
}
if (length($rhs) > $param{'maxDataSize'}) {
if ($msgType =~ /public/) {
if ($addressed) {
if (rand() > 0.5) {
&performSay("that is too long, ".$who);
} else {
&performSay("i'm sorry, but that's too long, $who");
}
}
} else {
&msg($who, "The text is too long");
}
return 'NOREPLY';
}
if ($msgType =~ /public/) {
&performSay("okay, $who.");
} else {
&msg($who, "okay.");
}
$updateCount++;
&status("update: <$who> \'$lhs =is=> $rhs\'; was \'$exists\'");
&set("is", $lhs, $rhs);
} else { # not "also"
if (($correction_plausible == 0) && ($exists ne $rhs)) {
if ($addressed) {
if (not $main::googling) {
if ($msgType =~ /public/) {
&performSay("...but $lhs is $exists...");
} else {
&msg($who, "...but $lhs is $exists..");
}
&status("FAILED update: <$who> \'$lhs =$verb=> $rhs\'");
}
} else {
&status("FAILED update: <$who> \'$lhs =$verb=> $rhs\' (not addressed, no reply)");
# we were not addressed, so just
# ignore it.
return 'NOREPLY';
}
} else {
if (IsFlag("m") ne "m") {
performReply("You have no access to change factoids");
return 'NOREPLY';
}
if ($msgType =~ /public/) {
&performSay("okay, $who.");
} else {
&msg($who, "okay.");
}
$updateCount++;
&status("update: <$who> '$lhs =is=> $rhs\'; was \'$exists\'");
&set("is", $lhs, $rhs);
}
}
$reply = 'NOREPLY';
} else {
&status("enter: <$who> $lhs =$verb=> $rhs");
$updateCount++; $factoidCount++;
if ($factoidCount == 31337) { # particular count
$mySaveChannel = &channel();
&say("That would be factoid $factoidCount given on $mySaveChannel by $who.");
&status("FACTOID NUMBER $factoidCount on channel $mySaveChannel by $who.");
&say("woohoo!");
&channel($mySaveChannel);
}
&set("is", $lhs, $rhs);
$is{"theCount"}++;
}
} else { # 'is' failed
if ($verb eq "are") {
$also = ($rhs =~ s/^also //i);
if ($exists = &get("are", $lhs)) {
if ($also) {
if ($exists ne $rhs) {
$rhs = $exists .' or '.$rhs;
}
if ($msgType =~ /public/) {
&performSay("okay, $who.") unless $rhs eq $exists;
} else {
&msg($who, "okay.");
}
$updateCount++;
&status("update: <$who> \'$lhs =are=> $rhs\'; was \'$exists\'");
&set("are", $lhs, $rhs);
} else { # not 'also'
if (($correction_plausible == 0) && ($exists ne $rhs)) {
if ($addressed) {
&status("FAILED update: \'$lhs =$verb=> $rhs\'");
if ($msgType =~ /public/) {
&performSay("...but $lhs is $exists...");
} else {
&msg($who, "...but $lhs is $exists..");
}
} else {
&status("FAILED update: $lhs $verb $rhs (not addressed, no reply)");
# we were not addressed, so just
# ignore it.
return 'NOREPLY';
}
if ($msgType =~ /public/) {
&performSay("...but $lhs are $exists...");
} else {
&msg($who, "...but $lhs are $exists...");
}
} else {
if ($msgType =~ /public/) {
&performSay("okay, $who.") unless $rhs eq $exists;
} else {
&msg($who, "okay.")
unless grep $_ eq $who, split /\s+/, $param{friendlyBots};
}
$updateCount++;
&status("update: <$who> \'$lhs =are=> $rhs\'; was \'$exists\'");
&set("are", $lhs, $rhs);
}
$reply = 'NOREPLY';
}
} else {
&status("enter: <$who> $lhs =are=> $rhs");
$updateCount++;
&set("are", $lhs, $rhs);
$are{"theCount"}++;
}
}
}
$lhs .= " $verb $rhs";
if ($reply ne 'NOREPLY') {
$reply = $lhs;
}
return $reply;
}
# ---
1;
|
|
|
#!/usr/bin/perl
#use strict;
require "DBM.pl";
sub status($)
{
print "status: ", @_, "\n";
}
if ((scalar(@ARGV) == 0) || (grep /^-/, @ARGV)) {
print "\n";
print " usage: $0 <sourcefile> <dbmname>\n";
print "\n";
print " adds elements in <sourcefile> to dbm <dbmname>\n";
print "\n";
print " <sourcefile> is a text file of one-per-line\n";
print " <key> => <value>\n";
print " pairs, \n";
print "\n";
print " <dbmname> the the basename of the dbm db\n";
print " (e.g. 'ubu-is')\n";
print "\n";
exit(1);
}
$sourcefile = $ARGV[0];
$dbname = $ARGV[1];
#openDBM($sourcefile);
#insertFile($sourcefile, $dbname);
#closeDBM($sourcefile);
open(IN, $sourcefile)
|| die "can\'t open $sourcefile as source\n";
dbmopen(db, $dbname, 0655) || die "Couldn't dbmopen \"$dbname\"";
$| = 1;
while (<IN>) {
chomp;
next if /^\s*$/;
if (!/=>/) {
print "skipping: $_";
next;
}
my ($left, $right) = split(/\s*=>\s*/, $_, 2);
$left =~ s/^\s*//;
$left =~ tr/A-Z/a-z/;
$right =~ s/\s+$//;
$db{$left} = $right;
print $left ." => ". $right ."\n" if (!(++$dcount % 100));
}
close(IN);
dbmclose(db);
exit;
|
|
|
# all the user stuff
#
# kevin lenzo
#
sub parseUserfile {
$file = $param{'miscdir'}.$filesep.$param{'userList'};
%user = ();
@userList = ();
open(FH, $file);
while (<FH>) {
if (!/^#/ && defined $_) {
if (/^UserEntry\s+(.+?)\s/) {
push @userList, $1;
$workname = $1;
if (/\s*\{\s*/) {
while (<FH>) {
if (/^\s*(\w+)\s+(.+);$/) {
$opt = $1; $val = $2;
$val =~ s/\"//g;
if ($opt =~ /^mask$/i) {
push @{$workname."masks"}, $val;
} elsif ($opt =~ /^flags$/i) {
$val =~ s/\+//;
$user{$workname."flags"} = $val;
} else {
$opt =~ tr/A-Z/a-z/;
$user{$workname.$opt} = $val;
}
} elsif (/^\s*\}\s*$/) {
last;
}
}
} else {
status("parse error: User Entry $workname without right brace");
}
}
}
}
my $u;
foreach $u (@userList) {
status("found user $user: flags +".$user{$u."flags"})
if $param{VERBOSITY} > 1;
if ($param{VERBOSITY} > 2) {
my $h;
foreach $h (@{$u."masks"}) {
status(" -> hostmask: $h");
}
}
}
}
sub IsFlag {
my $flags = $_[0];
my ($ret, $f, $o);
my @ind = split //, $flags;
foreach $f (split //, $uFlags) {
foreach $o (@ind) {
if ($f eq $o) {
$ret .= $f;
last;
}
}
}
$ret;
}
sub verifyUser {
my $lnuh = $_[0];
my ($u, $m);
my $VerifWho;
foreach $u (@userList) {
foreach (@{$u."masks"}) {
$m = $_;
$m =~ s/\*/.*?/g;
$m =~ s/([\@\(\)\[\]])/\\$1/g;
if ($lnuh =~ /^$m$/i) {
$VerifWho = $u;
last;
}
}
}
my $now = time();
my $m = $message;
if ($msgType !~ /public/) {
$m = "<private message>";
}
$seen{lc $who} = $now.$;.$m;
if ($VerifWho) {
$uFlags = $user{$VerifWho."flags"};
$uPasswd = $user{$VerifWho."pass"};
$uTitle = $user{$VerifWho."title"};
if (exists $seenVerif{$VerifWho} and
(time()-$seenVerif{$VerifWho} > 360)) {
status("mask verified for $VerifWho");
}
$seenVerif{$VerifWho} = $now;
}
return $VerifWho;
}
sub mkpasswd {
my $what = $_[0];
my $salt = chr(33+rand(64)).chr(33+rand(64));
$salt =~ s/:/;/g;
return crypt($what, $salt);
}
sub ckuser {
# returns user level if matched, zero otherwise
my ($nuh, $plaintextpass) = @_;
if (!$plaintextpass) {
($nuh, $plaintextpass) = split(/\s+/, $nuh);
}
return '' unless $nuh;
my ($level, $cryptedpass, $rest, $nuh2) = &userinfo($nuh);
if (&ckpasswd($plaintextpass, $cryptedpass)) {
# password matched for user nick!user@host
&status("confirmed user: $nuh");
return $level;
} else {
# no match
return 0;
}
}
sub ckpasswd {
# returns true if arg1 encrypts to arg2
my ($plain, $encrypted) = @_;
if (!$encrypted) {
($plain, $encrypted) = split(/\s+/, $plain, 2);
}
return '' unless ($plain && $encrypted);
my $salt = substr($encrypted, 0, 2);
return ($encrypted eq crypt($plain, $salt));
}
sub userinfo {
my $lnuh = $_[0];
my $k;
if (!$lnuh) {
$lnuh = $nuh;
}
foreach $k (keys %userList) {
my $n = $k;
$n =~ s/\*/.*/g;
$n =~ s/([\@\(\)\[\]])/\\$1/g;
if ($lnuh =~ /^$n$/i) {
# this may expand later
my ($userlevel, $pass, $rest) = split(/:/, $userList{$k}, 3);
return ($userlevel, $pass, $rest, $k);
}
}
return ();
}
sub users {
my @stuff;
foreach (sort keys %userList) {
push(@stuff, "$_ => $userList{$_}\n");
}
return @stuff;
}
sub adduser {
my($nuh, $level, $plainpass, $rest) = @_;
if (!$level) {
($nuh, $level, $plainpass, $rest) = split(/\s+/, $nuh, 4);
}
if (!$plainpass && ($level =~ /\D/)) {
my $x = $level;
if ($plainpass =~ /^\D+/) {
$level = $plainpass;
$plainpass = $level;
}
}
if (($level =~ /^\d+/) && $plainpass) {
my $cryptedpass = mkpasswd($plainpass);
my $i = join(":", $level, $cryptedpass, $rest);
$userLevel{$nuh} = $i;
&status("user $nuh added at level $i");
return "user $nuh added at level $i";
} else {
&status("bad params to adduser");
return '';
}
}
sub writeUserFile {
my $where = $_[0];
chomp $where;
if (!$where) {
$where = $param{'miscdir'}.$filesep.$param{'userList'};
}
if (!$where) {
return "no file given and no param set for writing user file\n";
}
if (open(UF, ">$where")) {
foreach (sort keys %userLevel) {
print UF "$_:$userLevel{$_}\n";
}
close UF;
&status("wrote user file to $where");
return "wrote user file";
} else {
&status("failed to write user file to $where");
return "couldn't write user file";
}
}
sub changepass {
my ($nuh, $oldpass, $newpass) = @_;
if (&ckuser($nuh, $oldpass)) {
my $cryptednew = mkpasswd($newpass);
my ($level, $pass, $rest, $nuh2) = &userinfo($nuh);
my $i = join(":", $level, $newpass, $rest);
$userList{$nuh2} = $i;
&status("password changed for $nuh");
return "password changed for $nuh";
} else {
&status("password change failed for $nuh");
return "password did not match you: $nuh";
}
}
sub removeuser {
my $nuh = $_[0];
if ($userList{$nuh}) {
delete $userList{$nuh};
&status("deleted $nuh from userlist");
return "deleted $nuh from the userlist";
} else {
return 'No match for $nuh';
}
}
sub setlevel {
my ($nuh, $newlevel) = @_;
if (!$newlevel) {
($nuh, $newlevel) = split(/\s+/, $nuh, 2);
}
my ($level, $pass, $rest, $nuh2) = &userinfo($nuh);
if ($newlevel !~ /^\d+/) {
return "bad user level: $newlevel";
}
if ($userList{$nuh}) {
($level, $pass, $rest) = split(/:/, $userList{$nuh});
$nuh2 = $nuh;
}
if ($nuh2) {
my $i = join(":", $newlevel, $pass, $rest);
$userList{$nuh2} = $i;
&status("level for $nuh changed to $newlevel (was $level)");
} else {
&status("no match for $nuh");
}
0;
}
sub userProcessing {
my $now = time();
if ($VerifWho) {
if ($msgType =~ /private/) {
my $unverified_message = "you must identify yourself; /msg $param{nick} <pass> <command>";
if (IsFlag("e") eq "e") { # eval
if ($message =~ s/^(\S+) eval//) {
if (!exists $verified{$VerifWho}) {
&status("unverified <$who> $message");
&msg($who, $unverified_message);
return 'NOREPLY';
}
my ($pass, $m) = ($1, $message);
$_ = "";
&msg($who, "WARNING: exposed eval security risk");
$x = eval($m);
&msg($who, $x);
}
}
if (IsFlag("o")) { # owner/operator flag
if ($message =~ /^die/) {
if (!exists $verified{$VerifWho}) {
&status("unverified <$who> $message");
&msg($who, $unverified_message);
return 'NOREPLY';
}
&rawout("QUIT :$who");
&closeDBM("is", "are");
dbmclose %seen;
dbmclose %plusplus;
status("Dying by $who\'s request");
exit(0);
}
if ($message =~ /^reload$/i) {
if (!exists $verified{$VerifWho}) {
&status("unverified <$who> $message");
&msg($who, $unverified_message);
return 'NOREPLY';
}
&status("RELOAD <$who>");
my $loaded;
opendir DIR, $infobot_src_dir;
while ($file = readdir DIR) {
next unless $file =~ /\.pl$/;
next if $file =~ /^Process.pl$/;
chomp $file;
$loaded .= "$file ";
do $file;
}
close DIR;
&msg($who, "reloaded init files");
return 'NOREPLY';
}
if ($message =~ /^rehash$/i) {
if (!exists $verified{$VerifWho}) {
&status("unverified <$who> $message");
&msg($who, $unverified_message);
return 'NOREPLY';
}
&status("REHASH <$who>\n");
&setup();
&msg($who, "rehashed");
return 'NOREPLY';
}
if ($message =~ /^modes$/) {
if (!exists $verified{$VerifWho}) {
&status("unverified <$who> $message");
&msg($who, $unverified_message);
return 'NOREPLY';
}
my ($chan, $mode, $user, $msg, $m1);
foreach $chan (keys %channels) {
my $msg = "$chan: ";
foreach $mode (keys %{$channels{$chan}}) {
my $m1 = $msg." $mode: ";
foreach $user (keys %{$channels{$chan}{$mode}}) {
$m1 .= "$user ";
}
&msg($who, $m1);
}
}
return 'NOREPLY';
}
}
if (IsFlag("p") eq "p") { # oP on channel
if ($message =~ s/^op( me)?$//i or $message =~ s/^op //i) {
if (!exists $verified{$VerifWho}) {
&status("unverified <$who> $message");
&msg($who, $unverified_message);
return 'NOREPLY';
}
&status("trying to op $who at their request");
foreach $chan (keys %channels) {
if ($message) {
&op($chan, $message);
} else {
&op($chan, $who);
}
}
return 'NOREPLY';
}
my $regex = 0;
if ($message =~ /^ignore\s+(.*)/) {
my $what = $1;
$ignoreList{$what}++;
&status("ignoring $what at $VerifWho's request");
&msg($who, "added $what to the ignore list");
return 'NOREPLY';
}
if ($message =~ /^ignorelist$/) {
&status("$who asked for the ignore list");
my $all = join " ", keys %ignoreList;
while (length($all) > 200) {
$all =~ s/(.{0,200}) //;
&msg($who, $1);
}
&msg($who, $all);
return 'NOREPLY';
}
if ($message =~ /^unignore\s+(.*)/) {
my $what = $1;
if ($ignoreList{$what}) {
&status("unignoring $what at $VerifWho's request");
delete $ignoreList{$what};
&msg($who, "removed $what from the ignore list");
} else {
&status("unignore FAILED for $1 at $who's request");
&msg($who, "no entry for $1 on the ignore list");
}
return 'NOREPLY';
}
}
}
} else {
$uFlags = $user{"defaultflags"};
}
}
1;
|
|
|
# WWWSearch backend, with queries updating the is-db (optionally)
# Uses WWW::Search::Google and WWW::Search
# originally Google.pl, drastically altered.
use strict;
package W3Search;
my @engines;
my $no_W3Search;
BEGIN {
$no_W3Search = 0;
eval "use WWW::Search";
$no_W3Search++ if $@;
eval "use WWW::Search::Google";
$no_W3Search++ if $@;
@engines = qw(AltaVista Dejanews Excite Gopher HotBot Infoseek
Lycos Magellan PLweb SFgate Simple Verity Google);
$W3Search::regex = join '|', @engines;
}
sub forking_W3Search {
if ($no_W3Search) {
&main::status("W3Search: this requires WWW::Search::Google to operate.");
return '';
}
my ($where, $what, $type, $callback) = @_;
$SIG{CHLD} = 'IGNORE';
my $pid = eval { fork() }; # catch non-forking OSes and other errors
return 'NOREPLY' if $pid; # parent does nothing
$callback->(W3Search($where, $what, $type));
exit 0 if defined $pid; # child exits, non-forking OS returns
}
sub W3Search {
if ($no_W3Search) {
&status("WWW search requires WWW::Search and WWW::Search::Google");
return 'sorry, can\'t do that';
} else {
my ($where, $what, $type) = @_;
my @matches = grep { lc($_) eq lc($where) ? $_ : undef } @engines;
if (!@matches) {
return "i don't know how to check '$where'";
} else {
$where = shift @matches;
}
my $Search = new WWW::Search($where);
my $Query = WWW::Search::escape_query($what);
$Search->native_query($Query);
my ($Result, $r, $count);
while ($r = $Search->next_result()) {
if ($Result) {
$Result .= " or ".$r->url();
} else {
$Result = $r->url();
}
last if ++$count >= 3;
}
if ($Result) {
if ($type =~ /update/) {
$main::correction_plausible++ if $type =~ /force/i;
$main::addressed++;
$main::googling = 1;
&main::update($what, "is", $Result);
$main::googling = 0;
}
return "$where says $what is $Result";
} else {
return "$where can't find $what";
}
}
}
1;
|
|
|
#!/usr/local/bin/perl
# usage:
# tzc-zwgc [-allpersonal] [-nopersonal] [regexp]
# only zgrams with instance matching regexp will be printed
# to use non-message class
# ((tzcfodder . subscribe) ("SOMECLASS" "*" "*"))
if (0) {
$allpersonal = 0;
$nopersonal = 0;
while (($arg = shift) && ($arg =~ /^-/)) {
if ($arg eq "-allpersonal") {
$allpersonal = 1;
} elsif ($arg eq "-nopersonal") {
$nopersonal = 1;
} else {
print STDERR "Unknown argument: $arg\n";
exit(-1);
}
if ($arg = shift) {
print STDERR "Extraneous argument: $arg\n";
exit(-1);
}
}
$regexp = $arg;
}
$allpersonal = 1;
$regexp = "";
$contained = "^infobot";
sub Zephyr {
$| = 1;
restart: while (1) {
open (F, "tzc -o |") || die "can't run tzc\n";
select F;
$/ = "\000";
select STDOUT;
while (<F>) {
# cut off everything up to & including the first ^A.
$i = index($_,"\001");
if ($i >= 0) {
$_ = substr($_,$i+1);
}
# get tzcspew tag (a symbol, usually "message")
if (/\(tzcspew \. ([^\)]*)\)/) {
$spew = $1;
} else {
next;
}
# on cutoff, try to restart
if ($spew eq 'cutoff') {
print "CUTOFF DETECTED. RESTARTING...\n";
next restart;
} elsif ($spew eq 'start') {
# ignore startup msg
next;
}
# ignore pings
if (/\(opcode . PING\)/) {
next;
}
# class (this is a symbol, although it probably shouldn't be)
if (/\(class \. ([^\)]*)\)/) {
$class = $1;
} else {
print "BAD CLASS: $_\n";
}
# sender
if (/\(sender \. "((\\.|[^\"\\])*)"\)/) {
$sender = &unquote($1);
# truncate, e.g., "dk3q@ANDREW.CMU.EDU", to "dk3q@ANDREW".
$fullsender = $sender;
if ($sender =~ /^(.*@[^\.]*)\./) {
$sender = $1;
}
} else {
print "BOGUS SENDER: $_";
}
# recipient (usually empty string or your kerberos principal)
if (/\(recipient \. \"((\\.|[^\"\\])*)\"\)/) {
$recipient = &unquote($1);
} else {
print "BOGUS RECIPIENT: $_";
}
# timestamp assigned at sending host
if (/\(time \. \"((\\.|[^\"\\])*)\"\)/) {
$timestr = &unquote($1);
$month = substr($timestr,4,3);
$hour = substr($timestr,11,2);
$day = substr($timestr,0,3);
} else {
print "BOGUS TIME: $_";
}
# host which sent the zgram
if (/\(fromhost \. \"((\\.|[^\"\\])*)\"\)/) {
$fromhost = &unquote($1);
} else {
print "BOGUS FROMHOST: $_";
}
# message (signature & body)
if (/\(message[ .\(]*\"((\\.|[^\"\\])*)\" \"((\\.|[^\"\\])*)/) {
$signature = &unquote($1);
$body = &unquote($3);
$signature =~ s/\n//;
} else {
# just skip messages with <2 parts
# (might be better to print with empty body
next;
}
# instance
if (/\(instance \. \"((\\.|[^\"\\])*)\"\)/) {
$instance = &unquote($1);
} else {
print "BOGUS INSTANCE: $_";
}
# if $allpersonal <> 0 then accept all personal zgrams
if (! ($allpersonal && $recipient ne "")) {
# reject personal zgrams if $nopersonal is nonzero
next if ($nopersonal && $recipient ne "");
# reject if $regexp is nonempty, it's not a personal zgram, and
# instance doesn't match $regexp
next if ($regexp ne "" && $instance !~ /$regexp/);
if (defined $ENV{'TZC_ZWGC_FILTER'} && -r $ENV{'TZC_ZWGC_FILTER'}) {
do $ENV{'TZC_ZWGC_FILTER'};
}
# other possible customizations:
# next if ($instance =~ /^zippy/); # ignore zippy* instances
# next if ($sender =~ /^gusciora$/); # ignore goofballs
}
# add terminating newline if necessary
if (substr($body,length($body)-1) ne "\n") {
$body = $body . "\n";
}
next if $instance =~ /^graffiti/i;
next if ($instance eq "PERSONAL");
next if $signature eq "zurl";
$body =~ s/\s+/ /g;
$who = lc($sender);
$nick = "zurl";
$param{nick} = $nick;
$body =~ s/^\s*infobot/zurl/i;
&ZephyrMsgHook($sender, $fromhost, $recipient, $instance, $timestr, $body, $signature);
}
close(F) || die "error in tzc\n";
}
exit(0);
}
############################################
sub unquote {
local($s) = @_;
$s =~ s/\\(.)/$1/g;
return $s;
}
|
|
|
# infobot :: Kevin Lenzo & Patrick Cole (c) 1997
$| = 1;
$SIG{'INT'} = 'killed';
$SIG{'KILL'} = 'killed';
$SIG{'TERM'} = 'killed';
$VER_MAJ = 0;
$VER_MIN = 38;
$VER_MOD = "0b";
$version = "infobot $VER_MAJ\.$VER_MIN\.$VER_MOD [lenzo + cole]";
$updateCount = 0;
$questionCount = 0;
$autorecon = 0;
$label = "(?:[a-zA-Z\d](?:(?:[a-zA-Z\d\-]+)?[a-zA-Z\d])?)";
$dmatch = "(?:(?:$label\.?)*$label)";
$ipmatch = "\d+\.\d+\.\d+\.\d";
$ischan = "[\#\&].*?";
$isnick = "[a-zA-Z]{1}[a-zA-Z0-9\_\-]+";
$SL = c('>', 'bold black').'>'.c('>', 'bold');
sub TimerAlarm {
&status("$TimerWho's timer ended. sending wakeup");
say("$TimerWho: this is your wake up call, foobar.");
say("$TimerWho: And again, fucknut. WAKE UP!");
}
sub killed {
my $quitMsg = $param{'quitMsg'} || "regrouping";
&quit($quitMsg);
&closeDBM("is", "are");
exit(1);
}
sub join {
return "no join yet on zephyr.";
foreach (@_) {
&status("joined $_");
# rawout("JOIN $_");
}
}
sub invite {
return "no invite on zephyr.";
my($who, $chan) = @_;
# rawout("INVITE $who $chan");
}
sub notice {
my($who, $msg) = @_;
foreach (split(/\n/, $msg)) {
# rawout("NOTICE $who :$_");
}
}
sub say1 {
return "say is unimplemented\n";
my $msg=$_[0];
if ($param{ansi_control}) {
print c('<','red').c($ident, 'bold red').c('>','red')." $msg\n";
} else {
print "<$b$ident$ob> $msg\n";
}
# rawout("PRIVMSG $talkchannel :$msg");
}
sub msg {
my ($nick, $msg) = @_;
print "msg *** " . substr($timestr,11,8) . " *** " . $signature . " (";
print $sender . "@" . $fromhost . "): ";
if ($instance ne "PERSONAL") {
print $instance;
}
print "\n";
print $body . "\n";
$msg =~ s/\s+/ /g;
$msg =~ s/\s*$/\n/;
if (!$msg) {
print "empty message: $msg\n";
} else {
# if ($instance !~ /$contained/) {
# return '' unless (($instance eq "PERSONAL") || ($instance eq "zurl"));
# }
print "-> $msg\n";
# this is a total hack.
if ($pid = fork) { # parent
sleep 1;
kill 9, $pid;
} else { # child
if ($tell_obj) {
open ZWRITE, "| zwrite -d $nick -s zurl";
} else {
open ZWRITE, "| zwrite -d $fullsender -s zurl";
}
$msg =~ s/(.{60,}?) /$1\n/g;
print ZWRITE $msg;
close ZWRITE;
exit(0);
}
}
return '';
}
sub say {
my $msg = $_[0];
print "say *** " . substr($timestr,11,8) . " *** " . $signature . " (";
print $sender . "@" . $fromhost . "): ";
if ($instance ne "PERSONAL") {
print $instance;
}
print "\n";
print $body . "\n";
$msg =~ s/\s+/ /g;
$msg =~ s/\s*$/\n/;
if (!$addressed) {
print "not addressed\n";
return;
}
if (!$msg) {
print "empty message: $msg\n";
} else {
# if ($instance !~ /$contained/) {
# return '' unless (($instance eq "PERSONAL") || ($instance eq "zurl"));
# }
print "-> $msg\n";
# this is a total hack.
if ($pid = fork) { # parent
sleep 1;
kill 9, $pid;
} else { # child
# if ($instance !~ /infobot/) {
if ($instance eq "zurl") {
open ZWRITE, "| zwrite -d $fullsender -s zurl";
# open ZWRITE, "| zwrite -s zurl $fullsender";
} else {
open ZWRITE, "| zwrite -d -i $instance -s zurl";
# open ZWRITE, "| zwrite -s zurl -c infobot -i infobot";
}
$msg =~ s/(.{60,}?) /$1\n/g;
print ZWRITE $msg;
close ZWRITE;
exit(0);
}
}
return '';
}
sub quit {
my $quitmsg = $_[0];
# rawout("QUIT :$quitmsg");
if ($param{ansi_control}) {
print "$SL $b$param{nick}$ob has quit IRC ($b$quitmsg$ob)\n";
} else {
print ">>> $b$param{nick}$ob has quit IRC ($b$quitmsg$ob)\n";
}
close(SOCK);
}
sub nick {
$nick = $_[0];
# rawout("NICK ".$nick);
}
sub part {
return "no part on zephyr\n";
foreach (@_) {
status("left $_");
# rawout("PART $_");
}
}
sub mode {
return "no mode on zephyr\n";
my ($chan, @modes) = @_;
my $modes = join(" ", @modes);
# rawout("MODE $chan $modes");
}
sub op {
return "no op on zephyr\n";
my ($chan, $arg) = @_;
$arg =~ s/^\s+//;
$arg =~ s/\s+$//;
$arg =~ s/\s+/ /;
my $os = "o" x scalar(split(/\s+/, $arg));
mode($chan, "+$os $arg");
}
sub deop {
return "no deop on zephyr\n";
my ($chan, $arg) = @_;
$arg =~ s/^\s+//;
$arg =~ s/\s+$//;
$arg =~ s/\s+/ /;
my $os = "o" x scalar(split(/\s+/, $arg));
&mode($chan, "-$os $arg");
}
sub timer {
($t, $timerStuff) = @_;
# alarm($t);
}
$SIG{"ALRM"} = \&doTimer;
sub doTimer {
# rawout($timerStuff);
}
sub channel {
return "no channel on zephyr yet\n";
if (scalar(@_) > 0) {
$talkchannel = $_[0];
}
$talkchannel;
}
sub rawout {
print "rawout: $_[0]\n";
return "";
$buf = $_[0];
$buf =~ s/\n//gi;
select(SOCK); $| = 1;
print SOCK "$buf\n";
select(STDOUT);
}
1;
|
|
|
# infobot :: Kevin Lenzo (c) 1997
# Tidied up ?
sub ZephyrActionHook
{
my ($nick, $channel, $message) = @_;
&channel($channel);
&process(0, $nick, 'public action', $message);
}
sub ZephyrMsgHook
{
my ($sender, $fromhost, $recipient, $instance, $timestr, $body, $signature) = @_;
$body =~ s/\s+/ /g;
$body =~ s/\s+$//;
$body =~ s/^\s+//;
my $xtype = "public";
if (($recipient ne "") && ($recipient ne "*")) {
$xtype = "private";
}
my ($adr, $type, $channel, $who, $message) = (0, $xtype, $instance, $sender, $body);
# return if ($ignoreList =~ /$who/);
if ($MLF{$who} == 1) { # This person is doing a mlf !!!
if ($message =~ /^<end>$/) {
${$who.'ft'} =~ s/\n+$//;
if ($MLF{$who.'verb'} eq "is") {
&set("is", $MLF{$who.'word'}, "MLF:".${$who.'ft'});
$is{"theCount"}++;
} elsif ($MLF{$who.'verb'} eq "are") {
&set("are", $MLF{$who.'word'}, "MLF:".${$who.'ft'});
$are{"theCount"}++;
}
undef ${$who.'ft'};
$MLF{$who} = 0;
&status("MLF Added: $MLF{$who.'word'}");
} else {
$message =~ s/\n//;
&status("ack: $message");
${$who.'ft'} .= $message;
${$who.'ft'} .= "\r";
}
return;
}
if ($type =~ /public/i) {
if ($adr == 1) {
$addressed_count++;
}
&channel($channel);
&process($adr, $who, $type, $message);
$lastAddressedBy = $who if ($adr);
}
if ($type =~ /private/i) {
if (($params{'mode'} eq 'IRC') && ($who eq $prevwho)) {
$delay = time-$prevtime."\n";
$prevcount++;
if ($delay < 1) {
if (!grep /^$who$/i, @specialPeople) {
&msg($who, "You will be ignored -- flood detected.");
#$ignore{$who}++;
&track("ignoring ".$who);
# $ignoreList .= " ".$t;
return;
}
}
return if (($message eq $prevmsg) && ($delay < 10));
} else {
$prevcount = 0;
$firsttime = time;
}
$prevtime = time unless ($message eq $prevmsg);
$prevmsg = $message;
$prevwho = $who;
&process($adr, $who, $type, $message);
}
return;
}
sub hook_dcc_request
{
my($type, $text) = @_;
if ($type =~ /chat/i) {
&status("received dcc chat request from $who : $text");
my($locWho) = $who;
$locWho =~ tr/A-Z/a-z/;
$locWho =~ s/\W//;
&docommand("dcc chat ".$who);
&msg('='.$who, "Hello, ".$who);
}
}
sub hook_dcc_chat
{
my($locWho, $message)=@_;
$msgType = "dcc_chat";
my($saveWho) = $who;
return if ($message =~ /enter your password/i);
return if ($who =~ /poundmac/i);
return if ($locWho =~ /poundmac/i);
$who = "=".$who;
&process($msgType, $message);
$who = $saveWho;
}
1;
|
|
|
bits for the Zephyr version. probably not useful without contact
lenzo@cs.cmu.edu
|